summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2018-09-13 19:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-13 19:52:00 (GMT)
commitc1b57005ac147582e36f0081b177ca8117127c68 (patch)
tree05b8d1a37caed894d68418b90af87fbd5a9c739d
parent31aa1932c69c9d9d6a1e0b2a9f997fcd3b5af2fd (diff)
version 6.201809136.20180913
-rw-r--r--Annex.hs4
-rw-r--r--Annex/AdjustedBranch.hs2
-rw-r--r--Annex/Branch/Transitions.hs20
-rw-r--r--Annex/CatFile.hs1
-rw-r--r--Annex/Concurrent.hs6
-rw-r--r--Annex/Content.hs184
-rw-r--r--Annex/Content/LowLevel.hs139
-rw-r--r--Annex/Content/PointerFile.hs57
-rw-r--r--Annex/Direct.hs2
-rw-r--r--Annex/Drop.hs10
-rw-r--r--Annex/FileMatcher.hs21
-rw-r--r--Annex/Ingest.hs29
-rw-r--r--Annex/Init.hs1
-rw-r--r--Annex/Link.hs96
-rw-r--r--Annex/Locations.hs6
-rw-r--r--Annex/Queue.hs28
-rw-r--r--Annex/ReplaceFile.hs5
-rw-r--r--Annex/YoutubeDl.hs5
-rw-r--r--Backend/Hash.hs83
-rw-r--r--Build/BundledPrograms.hs7
-rw-r--r--Build/Configure.hs33
-rw-r--r--CHANGELOG51
-rw-r--r--CmdLine/Batch.hs19
-rw-r--r--CmdLine/Seek.hs24
-rw-r--r--Command/Add.hs12
-rw-r--r--Command/Copy.hs2
-rw-r--r--Command/Drop.hs2
-rw-r--r--Command/Export.hs14
-rw-r--r--Command/Find.hs2
-rw-r--r--Command/Get.hs2
-rw-r--r--Command/ImportFeed.hs4
-rw-r--r--Command/MetaData.hs10
-rw-r--r--Command/Move.hs2
-rw-r--r--Command/ReKey.hs2
-rw-r--r--Command/Reinject.hs2
-rw-r--r--Command/Smudge.hs96
-rw-r--r--Command/Whereis.hs2
-rw-r--r--Config.hs18
-rw-r--r--Config/Smudge.hs41
-rw-r--r--Database/Keys.hs137
-rw-r--r--Git/CurrentRepo.hs23
-rw-r--r--Git/Index.hs11
-rw-r--r--Git/Queue.hs40
-rw-r--r--Git/UpdateIndex.hs23
-rw-r--r--Logs.hs14
-rw-r--r--Logs/MetaData.hs121
-rw-r--r--Logs/MetaData/Pure.hs111
-rw-r--r--Logs/PreferredContent.hs2
-rw-r--r--Logs/SingleValue.hs40
-rw-r--r--Logs/SingleValue/Pure.hs45
-rw-r--r--Logs/Trust.hs8
-rw-r--r--P2P/IO.hs7
-rw-r--r--P2P/Protocol.hs4
-rw-r--r--Remote/Adb.hs1
-rw-r--r--Remote/BitTorrent.hs1
-rw-r--r--Remote/Bup.hs1
-rw-r--r--Remote/Ddar.hs1
-rw-r--r--Remote/Directory.hs1
-rw-r--r--Remote/External.hs1
-rw-r--r--Remote/GCrypt.hs1
-rw-r--r--Remote/Git.hs1
-rw-r--r--Remote/Glacier.hs1
-rw-r--r--Remote/Helper/Export.hs72
-rw-r--r--Remote/Hook.hs1
-rw-r--r--Remote/P2P.hs1
-rw-r--r--Remote/Rsync.hs1
-rw-r--r--Remote/S3.hs260
-rw-r--r--Remote/Tahoe.hs1
-rw-r--r--Remote/Web.hs1
-rw-r--r--Remote/WebDAV.hs1
-rw-r--r--Types/MetaData.hs38
-rw-r--r--Types/Remote.hs7
-rw-r--r--Upgrade/V5.hs1
-rw-r--r--Utility/DirWatcher/Kqueue.hs6
-rw-r--r--Utility/ExternalSHA.hs67
-rw-r--r--Utility/Mounts.hs3
-rw-r--r--Utility/SRV.hs52
-rw-r--r--Utility/SafeCommand.hs20
-rw-r--r--Utility/SimpleProtocol.hs2
-rw-r--r--Utility/Tmp/Dir.hs2
-rw-r--r--doc/git-annex-add.mdwn5
-rw-r--r--doc/git-annex-copy.mdwn5
-rw-r--r--doc/git-annex-drop.mdwn5
-rw-r--r--doc/git-annex-export.mdwn7
-rw-r--r--doc/git-annex-get.mdwn3
-rw-r--r--doc/git-annex-metadata.mdwn3
-rw-r--r--doc/git-annex-move.mdwn3
-rw-r--r--doc/git-annex-whereis.mdwn3
-rw-r--r--doc/git-annex.mdwn8
-rw-r--r--git-annex.cabal173
90 files changed, 1559 insertions, 831 deletions
diff --git a/Annex.hs b/Annex.hs
index afca182..bdedec3 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -73,6 +73,7 @@ import "mtl" Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
+import qualified Control.Concurrent.SSem as SSem
import qualified Data.Map.Strict as M
import qualified Data.Set as S
@@ -111,6 +112,7 @@ data AnnexState = AnnexState
, daemon :: Bool
, branchstate :: BranchState
, repoqueue :: Maybe Git.Queue.Queue
+ , repoqueuesem :: SSem.SSem
, catfilehandles :: M.Map FilePath CatFileHandle
, hashobjecthandle :: Maybe HashObjectHandle
, checkattrhandle :: Maybe CheckAttrHandle
@@ -153,6 +155,7 @@ newState c r = do
emptyactivekeys <- newTVarIO M.empty
o <- newMessageState
sc <- newTMVarIO False
+ qsem <- SSem.new 1
return $ AnnexState
{ repo = r
, repoadjustment = return
@@ -168,6 +171,7 @@ newState c r = do
, daemon = False
, branchstate = startBranchState
, repoqueue = Nothing
+ , repoqueuesem = qsem
, catfilehandles = M.empty
, hashobjecthandle = Nothing
, checkattrhandle = Nothing
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
index 42ea827..aae8128 100644
--- a/Annex/AdjustedBranch.hs
+++ b/Annex/AdjustedBranch.hs
@@ -270,7 +270,7 @@ preventCommits :: (CommitsPrevented -> Annex a) -> Annex a
preventCommits = bracket setup cleanup
where
setup = do
- lck <- fromRepo indexFileLock
+ lck <- fromRepo $ indexFileLock . indexFile
liftIO $ Git.LockFile.openLock lck
cleanup = liftIO . Git.LockFile.closeLock
diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs
index 7b1f32b..c2283f3 100644
--- a/Annex/Branch/Transitions.hs
+++ b/Annex/Branch/Transitions.hs
@@ -1,6 +1,6 @@
{- git-annex branch transitions
-
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -15,10 +15,13 @@ import Logs.Transitions
import qualified Logs.UUIDBased as UUIDBased
import qualified Logs.Presence.Pure as Presence
import qualified Logs.Chunk.Pure as Chunk
+import qualified Logs.MetaData.Pure as MetaData
import Types.TrustLevel
import Types.UUID
+import Types.MetaData
import qualified Data.Map as M
+import qualified Data.Set as S
import Data.Default
data FileTransition
@@ -49,16 +52,27 @@ dropDead f content trustmap = case getLogVariety f of
in if null newlog
then RemoveFile
else ChangeFile $ Presence.showLog newlog
+ Just RemoteMetaDataLog ->
+ let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content
+ in if S.null newlog
+ then RemoveFile
+ else ChangeFile $ MetaData.showLog newlog
Just OtherLog -> PreserveFile
Nothing -> PreserveFile
dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v
-dropDeadFromMapLog trustmap getuuid = M.filterWithKey $ \k _v -> notDead trustmap getuuid k
+dropDeadFromMapLog trustmap getuuid =
+ M.filterWithKey $ \k _v -> notDead trustmap getuuid k
{- 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)
+dropDeadFromPresenceLog trustmap =
+ filter $ notDead trustmap (toUUID . Presence.info)
+
+dropDeadFromRemoteMetaDataLog :: TrustMap -> MetaData.Log MetaData -> MetaData.Log MetaData
+dropDeadFromRemoteMetaDataLog trustmap =
+ MetaData.filterOutEmpty . MetaData.filterRemoteMetaData (notDead trustmap id)
notDead :: TrustMap -> (v -> UUID) -> v -> Bool
notDead trustmap a v = M.findWithDefault def (a v) trustmap /= DeadTrusted
diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs
index 25952df..7062f78 100644
--- a/Annex/CatFile.hs
+++ b/Annex/CatFile.hs
@@ -13,6 +13,7 @@ module Annex.CatFile (
catCommit,
catObjectDetails,
catFileHandle,
+ catObjectMetaData,
catFileStop,
catKey,
catKeyFile,
diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs
index 65acb04..2e92d18 100644
--- a/Annex/Concurrent.hs
+++ b/Annex/Concurrent.hs
@@ -41,9 +41,13 @@ forkState a = do
dupState :: Annex AnnexState
dupState = do
st <- Annex.getState id
- -- avoid sharing eg, open file handles
return $ st
{ Annex.workers = []
+ -- each thread has its own repoqueue, but the repoqueuesem
+ -- is shared to prevent more than one thread flushing its
+ -- queue at the same time
+ , Annex.repoqueue = Nothing
+ -- avoid sharing eg, open file handles
, Annex.catfilehandles = M.empty
, Annex.checkattrhandle = Nothing
, Annex.checkignorehandle = Nothing
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 8011a82..5d657ca 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -54,7 +54,6 @@ module Annex.Content (
) where
import System.IO.Unsafe (unsafeInterleaveIO)
-import System.PosixCompat.Files
import qualified Data.Set as S
import Annex.Common
@@ -65,10 +64,8 @@ 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 Utility.DataUnits
import Utility.CopyFile
import Utility.Metered
import Config
@@ -89,6 +86,8 @@ import Types.Key
import Annex.UUID
import Annex.InodeSentinal
import Utility.InodeCache
+import Annex.Content.LowLevel
+import Annex.Content.PointerFile
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
@@ -453,56 +452,11 @@ withTmp key action = do
pruneTmpWorkDirBefore tmp (liftIO . nukeFile)
return res
-{- Checks that there is disk space available to store a given key,
- - in a destination directory (or the annex) printing a warning if not.
- -
- - If the destination is on the same filesystem as the annex,
- - checks for any other running downloads, removing the amount of data still
- - to be downloaded from the free space. This way, we avoid overcommitting
- - when doing concurrent downloads.
- -}
-checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
-checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key
-
-{- Allows specifying the size of the key, if it's known, which is useful
- - as not all keys know their size. -}
-checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
-checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)
- ( return True
- , do
- -- We can't get inprogress and free at the same
- -- time, and both can be changing, so there's a
- -- small race here. Err on the side of caution
- -- by getting inprogress first, so if it takes
- -- a while, we'll see any decrease in the free
- -- disk space.
- inprogress <- if samefilesystem
- then sizeOfDownloadsInProgress (/= key)
- else pure 0
- dir >>= liftIO . getDiskFree >>= \case
- Just have -> do
- reserve <- annexDiskReserve <$> Annex.getGitConfig
- let delta = need + reserve - have - alreadythere + inprogress
- let ok = delta <= 0
- unless ok $
- warning $ needMoreDiskSpace delta
- return ok
- _ -> return True
- )
- where
- dir = maybe (fromRepo gitAnnexDir) return destdir
-
-needMoreDiskSpace :: Integer -> String
-needMoreDiskSpace n = "not enough free space, need " ++
- roughSize storageUnits True n ++ " more" ++ forcemsg
- where
- forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
-
{- Moves a key's content into .git/annex/objects/
-
- When a key has associated pointer files, the object is hard
- linked (or copied) to the files, and the object file is left thawed.
-
+ -
- In direct mode, moves the object file to the associated file, or files.
-
- What if the key there already has content? This could happen for
@@ -545,8 +499,8 @@ moveAnnex key src = ifM (checkSecureHashes key)
fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key
unless (null fs) $ do
- mapM_ (populatePointerFile key dest) fs
- Database.Keys.storeInodeCaches key (dest:fs)
+ ics <- mapM (populatePointerFile (Restage True) key dest) fs
+ Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)
)
storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
@@ -586,18 +540,6 @@ checkSecureHashes key
, return True
)
-populatePointerFile :: Key -> FilePath -> FilePath -> Annex ()
-populatePointerFile k obj f = go =<< liftIO (isPointerFile f)
- where
- go (Just k') | k == k' = do
- destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
- liftIO $ nukeFile f
- ifM (linkOrCopy k obj f destmode)
- ( thawContent f
- , liftIO $ writePointerFile f k destmode
- )
- go _ = return ()
-
data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
{- Populates the annex object file by hard linking or copying a source
@@ -622,11 +564,12 @@ data FromTo = From | To
{- Hard links or copies from or to the annex object location.
- Updates inode cache.
-
- - Thaws the file that is not the annex object.
- - When a hard link was made, this necessarily thaws
- - the annex object too. So, adding an object to the annex this
- - way can prevent losing the content if the source file
- - is deleted, but does not guard against modifications.
+ - Freezes or thaws the destination appropriately.
+ -
+ - When a hard link is made, the annex object necessarily has to be thawed
+ - too. So, adding an object to the annex with a hard link can prevent
+ - losing the content if the source file is deleted, but does not
+ - guard against modifications.
-
- Nothing is done if the destination file already exists.
-}
@@ -640,14 +583,15 @@ linkAnnex fromto key src (Just srcic) dest destmode =
then Database.Keys.addInodeCaches key [srcic, destic]
else Database.Keys.addInodeCaches key [srcic]
return LinkAnnexNoop
- Nothing -> ifM (linkOrCopy key src dest destmode)
- ( do
- thawContent $ case fromto of
- From -> dest
- To -> src
+ Nothing -> linkOrCopy key src dest destmode >>= \case
+ Nothing -> failed
+ Just r -> do
+ case fromto of
+ From -> thawContent dest
+ To -> case r of
+ Copied -> freezeContent dest
+ Linked -> noop
checksrcunchanged
- , failed
- )
where
failed = do
Database.Keys.addInodeCaches key [srcic]
@@ -662,40 +606,6 @@ linkAnnex fromto key src (Just srcic) dest destmode =
liftIO $ nukeFile dest
failed
-{- Hard links or copies src to dest, which must not already exists.
- -
- - Only uses a hard link when annex.thin is enabled and when src is
- - not already hardlinked to elsewhere.
- -
- - Checks disk reserve before copying against the size of the key,
- - and will fail if not enough space, or if the dest file already exists.
- -
- - The FileMode, if provided, influences the mode of the dest file.
- - In particular, if it has an execute bit set, the dest file's
- - execute bit will be set. The mode is not fully copied over because
- - git doesn't support file modes beyond execute.
- -}
-linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
-linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)
-
-linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
-linkOrCopy' canhardlink key src dest destmode
- | maybe False isExecutable destmode = copy =<< getstat
- | otherwise = catchBoolIO $
- ifM canhardlink
- ( hardlink
- , copy =<< getstat
- )
- where
- hardlink = do
- s <- getstat
- if linkCount s > 1
- then copy s
- else liftIO (createLink src dest >> preserveGitMode dest destmode >> return True)
- `catchIO` const (copy s)
- copy = checkedCopyFile' key src dest destmode
- getstat = liftIO $ getFileStatus src
-
{- Removes the annex object file for a key. Lowlevel. -}
unlinkAnnex :: Key -> Annex ()
unlinkAnnex key = do
@@ -704,31 +614,6 @@ unlinkAnnex key = do
secureErase obj
liftIO $ nukeFile obj
-{- Checks disk space before copying. -}
-checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
-checkedCopyFile key src dest destmode = catchBoolIO $
- checkedCopyFile' key src dest destmode
- =<< liftIO (getFileStatus src)
-
-checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool
-checkedCopyFile' key src dest destmode s = catchBoolIO $
- ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)
- ( liftIO $
- copyFileExternal CopyAllMetaData src dest
- <&&> preserveGitMode dest destmode
- , return False
- )
-
-preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool
-preserveGitMode f (Just mode)
- | isExecutable mode = catchBoolIO $ do
- modifyFileMode f $ addModes executeModes
- return True
- | otherwise = catchBoolIO $ do
- modifyFileMode f $ removeModes executeModes
- return True
-preserveGitMode _ _ = return True
-
{- Runs an action to transfer an object's content.
-
- In some cases, it's possible for the file to change as it's being sent.
@@ -816,12 +701,6 @@ cleanObjectLoc key cleaner = do
<=< catchMaybeIO $ removeDirectory dir
{- Removes a key's file from .git/annex/objects/
- -
- - When a key has associated pointer files, they are checked for
- - modifications, and if unmodified, are reset.
- -
- - In direct mode, deletes the associated files or files, and replaces
- - them with symlinks.
-}
removeAnnex :: ContentRemovalLock -> Annex ()
removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
@@ -834,22 +713,25 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
=<< Database.Keys.getAssociatedFiles key
Database.Keys.removeInodeCaches key
Direct.removeInodeCache key
+
+ -- Check associated pointer file for modifications, and reset if
+ -- it's unmodified.
resetpointer file = ifM (isUnmodified key file)
- ( do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
- secureErase file
- liftIO $ nukeFile file
- liftIO $ writePointerFile file key mode
- -- Can't delete the pointer file.
+ ( depopulatePointerFile key file
+ -- Modified file, so leave it alone.
-- If it was a hard link to the annex object,
-- that object might have been frozen as part of the
-- removal process, so thaw it.
, void $ tryIO $ thawContent file
)
+
+ -- In direct mode, deletes the associated files or files, and replaces
+ -- them with symlinks.
removedirect fs = do
cache <- Direct.recordedInodeCache key
Direct.removeInodeCache key
mapM_ (resetfile cache) fs
+
resetfile cache f = whenM (Direct.sameInodeCache f cache) $ do
l <- calcRepo $ gitAnnexLink f key
secureErase f
@@ -875,16 +757,6 @@ isUnmodified key f = go =<< geti
)
geti = withTSDelta (liftIO . genInodeCache f)
-{- 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 out of .git/annex/objects/ into .git/annex/bad, and
- returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath
diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs
new file mode 100644
index 0000000..54fc0a4
--- /dev/null
+++ b/Annex/Content/LowLevel.hs
@@ -0,0 +1,139 @@
+{- git-annex low-level content functions
+ -
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Content.LowLevel where
+
+import System.PosixCompat.Files
+
+import Annex.Common
+import Logs.Transfer
+import qualified Annex
+import Utility.DiskFree
+import Utility.FileMode
+import Utility.DataUnits
+import Utility.CopyFile
+
+{- 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) ]
+
+data LinkedOrCopied = Linked | Copied
+
+{- Hard links or copies src to dest, which must not already exist.
+ -
+ - Only uses a hard link when annex.thin is enabled and when src is
+ - not already hardlinked to elsewhere.
+ -
+ - Checks disk reserve before copying against the size of the key,
+ - and will fail if not enough space, or if the dest file already exists.
+ -
+ - The FileMode, if provided, influences the mode of the dest file.
+ - In particular, if it has an execute bit set, the dest file's
+ - execute bit will be set. The mode is not fully copied over because
+ - git doesn't support file modes beyond execute.
+ -}
+linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
+linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)
+
+linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
+linkOrCopy' canhardlink key src dest destmode
+ | maybe False isExecutable destmode = copy =<< getstat
+ | otherwise = catchDefaultIO Nothing $
+ ifM canhardlink
+ ( hardlink
+ , copy =<< getstat
+ )
+ where
+ hardlink = do
+ s <- getstat
+ if linkCount s > 1
+ then copy s
+ else liftIO (createLink src dest >> preserveGitMode dest destmode >> return (Just Linked))
+ `catchIO` const (copy s)
+ copy s = ifM (checkedCopyFile' key src dest destmode s)
+ ( return (Just Copied)
+ , return Nothing
+ )
+ getstat = liftIO $ getFileStatus src
+
+{- Checks disk space before copying. -}
+checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
+checkedCopyFile key src dest destmode = catchBoolIO $
+ checkedCopyFile' key src dest destmode
+ =<< liftIO (getFileStatus src)
+
+checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool
+checkedCopyFile' key src dest destmode s = catchBoolIO $
+ ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)
+ ( liftIO $
+ copyFileExternal CopyAllMetaData src dest
+ <&&> preserveGitMode dest destmode
+ , return False
+ )
+
+preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool
+preserveGitMode f (Just mode)
+ | isExecutable mode = catchBoolIO $ do
+ modifyFileMode f $ addModes executeModes
+ return True
+ | otherwise = catchBoolIO $ do
+ modifyFileMode f $ removeModes executeModes
+ return True
+preserveGitMode _ _ = return True
+
+{- Checks that there is disk space available to store a given key,
+ - in a destination directory (or the annex) printing a warning if not.
+ -
+ - If the destination is on the same filesystem as the annex,
+ - checks for any other running downloads, removing the amount of data still
+ - to be downloaded from the free space. This way, we avoid overcommitting
+ - when doing concurrent downloads.
+ -}
+checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
+checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key
+
+{- Allows specifying the size of the key, if it's known, which is useful
+ - as not all keys know their size. -}
+checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
+checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)
+ ( return True
+ , do
+ -- We can't get inprogress and free at the same
+ -- time, and both can be changing, so there's a
+ -- small race here. Err on the side of caution
+ -- by getting inprogress first, so if it takes
+ -- a while, we'll see any decrease in the free
+ -- disk space.
+ inprogress <- if samefilesystem
+ then sizeOfDownloadsInProgress (/= key)
+ else pure 0
+ dir >>= liftIO . getDiskFree >>= \case
+ Just have -> do
+ reserve <- annexDiskReserve <$> Annex.getGitConfig
+ let delta = need + reserve - have - alreadythere + inprogress
+ let ok = delta <= 0
+ unless ok $
+ warning $ needMoreDiskSpace delta
+ return ok
+ _ -> return True
+ )
+ where
+ dir = maybe (fromRepo gitAnnexDir) return destdir
+
+needMoreDiskSpace :: Integer -> String
+needMoreDiskSpace n = "not enough free space, need " ++
+ roughSize storageUnits True n ++ " more" ++ forcemsg
+ where
+ forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs
new file mode 100644
index 0000000..1aba305
--- /dev/null
+++ b/Annex/Content/PointerFile.hs
@@ -0,0 +1,57 @@
+{- git-annex pointer files
+ -
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Content.PointerFile where
+
+import System.PosixCompat.Files
+
+import Annex.Common
+import Annex.Perms
+import Annex.Link
+import Annex.ReplaceFile
+import Annex.InodeSentinal
+import Utility.InodeCache
+import Annex.Content.LowLevel
+
+{- Populates a pointer file with the content of a key.
+ -
+ - If the file already has some other content, it is not modified.
+ -
+ - Returns an InodeCache if it populated the pointer file.
+ -}
+populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex (Maybe InodeCache)
+populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
+ where
+ go (Just k') | k == k' = do
+ destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
+ liftIO $ nukeFile f
+ (ic, populated) <- replaceFile f $ \tmp -> do
+ ok <- linkOrCopy k obj tmp destmode >>= \case
+ Just _ -> thawContent tmp >> return True
+ Nothing -> liftIO (writePointerFile tmp k destmode) >> return False
+ ic <- withTSDelta (liftIO . genInodeCache tmp)
+ return (ic, ok)
+ maybe noop (restagePointerFile restage f) ic
+ if populated
+ then return ic
+ else return Nothing
+ go _ = return Nothing
+
+{- Removes the content from a pointer file, replacing it with a pointer.
+ -
+ - Does not check if the pointer file is modified. -}
+depopulatePointerFile :: Key -> FilePath -> Annex ()
+depopulatePointerFile key file = do
+ mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
+ secureErase file
+ liftIO $ nukeFile file
+ ic <- replaceFile file $ \tmp -> do
+ liftIO $ writePointerFile tmp key mode
+ withTSDelta (liftIO . genInodeCache tmp)
+ maybe noop (restagePointerFile (Restage True) file) ic
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index 57e363a..5ca9ec1 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -164,7 +164,7 @@ addDirect file cache = do
mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Annex Bool
mergeDirect startbranch oldref branch resolvemerge mergeconfig commitmode = exclusively $ do
reali <- liftIO . absPath =<< fromRepo indexFile
- tmpi <- liftIO . absPath =<< fromRepo indexFileLock
+ tmpi <- liftIO . absPath =<< fromRepo (indexFileLock . indexFile)
liftIO $ whenM (doesFileExist reali) $
copyFile reali tmpi
diff --git a/Annex/Drop.hs b/Annex/Drop.hs
index 1723bce..a2b1322 100644
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@@ -11,7 +11,7 @@ import Annex.Common
import qualified Annex
import Logs.Trust
import Annex.NumCopies
-import Types.Remote (uuid)
+import Types.Remote (uuid, appendonly)
import qualified Remote
import qualified Command.Drop
import Command
@@ -29,6 +29,9 @@ type Reason = String
{- Drop a key from local and/or remote when allowed by the preferred content
- and numcopies settings.
-
+ - Skips trying to drop from remotes that are appendonly, since those drops
+ - would presumably fail.
+ -
- 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.
@@ -58,9 +61,10 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
AssociatedFile (Just f) -> nub (f : l)
AssociatedFile Nothing -> l
n <- getcopies fs
+ let rs' = filter (not . appendonly) rs
void $ if fromhere && checkcopies n Nothing
- then go fs rs n >>= dropl fs
- else go fs rs n
+ then go fs rs' n >>= dropl fs
+ else go fs rs' n
where
getcopies fs = do
(untrusted, have) <- trustPartition UnTrusted locs
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index 722f2b3..44565e3 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -10,6 +10,7 @@
module Annex.FileMatcher (
GetFileMatcher,
checkFileMatcher,
+ checkFileMatcher',
checkMatcher,
matchAll,
preferredContentParser,
@@ -42,17 +43,25 @@ import qualified Data.Set as S
type GetFileMatcher = FilePath -> Annex (FileMatcher Annex)
checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool
-checkFileMatcher getmatcher file = do
+checkFileMatcher getmatcher file = checkFileMatcher' getmatcher file (return True)
+
+-- | Allows running an action when no matcher is configured for the file.
+checkFileMatcher' :: GetFileMatcher -> FilePath -> Annex Bool -> Annex Bool
+checkFileMatcher' getmatcher file notconfigured = do
matcher <- getmatcher file
- checkMatcher matcher Nothing (AssociatedFile (Just file)) S.empty True
+ checkMatcher matcher Nothing afile S.empty notconfigured d
+ where
+ afile = AssociatedFile (Just file)
+ -- checkMatcher will never use this, because afile is provided.
+ d = return True
-checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
-checkMatcher matcher mkey afile notpresent d
- | isEmpty matcher = return d
+checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool
+checkMatcher matcher mkey afile notpresent notconfigured d
+ | isEmpty matcher = notconfigured
| otherwise = case (mkey, afile) of
(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
(Just key, _) -> go (MatchingKey key)
- _ -> return d
+ _ -> d
where
go mi = matchMrun matcher $ \a -> a notpresent mi
diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs
index 1bc0815..aa556b3 100644
--- a/Annex/Ingest.hs
+++ b/Annex/Ingest.hs
@@ -140,14 +140,13 @@ ingestAdd' ld@(Just (LockedDown cfg source)) mk = do
return (Just k)
{- Ingests a locked down file into the annex. Does not update the working
- - tree or the index.
- -}
+ - tree or the index. -}
ingest :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)
-ingest = ingest' Nothing
+ingest ld mk = ingest' Nothing ld mk (Restage True)
-ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)
-ingest' _ Nothing _ = return (Nothing, Nothing)
-ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delta -> do
+ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache)
+ingest' _ Nothing _ _ = return (Nothing, Nothing)
+ingest' preferredbackend (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do
k <- case mk of
Nothing -> do
backend <- maybe (chooseBackend $ keyFilename source) (return . Just) preferredbackend
@@ -172,7 +171,7 @@ ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delt
golocked key mcache s =
tryNonAsync (moveAnnex key $ contentLocation source) >>= \case
Right True -> do
- populateAssociatedFiles key source
+ populateAssociatedFiles key source restage
success key mcache s
Right False -> giveup "failed to add content to annex"
Left e -> restoreFile (keyFilename source) key e
@@ -186,7 +185,7 @@ ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delt
linkToAnnex key (keyFilename source) (Just cache) >>= \case
LinkAnnexFailed -> failure "failed to link to annex"
_ -> do
- finishIngestUnlocked' key source
+ finishIngestUnlocked' key source restage
success key (Just cache) s
gounlocked _ _ _ = failure "failed statting file"
@@ -218,23 +217,23 @@ finishIngestDirect key source = do
finishIngestUnlocked :: Key -> KeySource -> Annex ()
finishIngestUnlocked key source = do
cleanCruft source
- finishIngestUnlocked' key source
+ finishIngestUnlocked' key source (Restage True)
-finishIngestUnlocked' :: Key -> KeySource -> Annex ()
-finishIngestUnlocked' key source = do
+finishIngestUnlocked' :: Key -> KeySource -> Restage -> Annex ()
+finishIngestUnlocked' key source restage = do
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (keyFilename source))
- populateAssociatedFiles key source
+ populateAssociatedFiles key source restage
{- Copy to any other locations using the same key. -}
-populateAssociatedFiles :: Key -> KeySource -> Annex ()
-populateAssociatedFiles key source = do
+populateAssociatedFiles :: Key -> KeySource -> Restage -> Annex ()
+populateAssociatedFiles key source restage = do
obj <- calcRepo (gitAnnexLocation key)
g <- Annex.gitRepo
ingestedf <- flip fromTopFilePath g
<$> inRepo (toTopFilePath (keyFilename source))
afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
forM_ (filter (/= ingestedf) afs) $
- populatePointerFile key obj
+ populatePointerFile restage key obj
cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $
diff --git a/Annex/Init.hs b/Annex/Init.hs
index 1d4093f..802524c 100644
--- a/Annex/Init.hs
+++ b/Annex/Init.hs
@@ -35,6 +35,7 @@ import Annex.UUID
import Annex.Link
import Annex.WorkTree
import Config
+import Config.Smudge
import Annex.Direct
import Annex.AdjustedBranch
import Annex.Environment
diff --git a/Annex/Link.hs b/Annex/Link.hs
index a75ed05..ba12060 100644
--- a/Annex/Link.hs
+++ b/Annex/Link.hs
@@ -7,7 +7,7 @@
-
- Pointer files are used instead of symlinks for unlocked files.
-
- - Copyright 2013-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -18,13 +18,22 @@ module Annex.Link where
import Annex.Common
import qualified Annex
-import qualified Git.UpdateIndex
import qualified Annex.Queue
+import qualified Git.Queue
+import qualified Git.UpdateIndex
+import qualified Git.Index
+import qualified Git.LockFile
+import qualified Git.Env
+import qualified Git
import Git.Types
import Git.FilePath
import Annex.HashObject
+import Annex.InodeSentinal
import Utility.FileMode
import Utility.FileSystemEncoding
+import Utility.InodeCache
+import Utility.Tmp.Dir
+import Utility.CopyFile
import qualified Data.ByteString.Lazy as L
@@ -131,6 +140,89 @@ writePointerFile file k mode = do
writeFile file (formatPointer k)
maybe noop (setFileMode file) mode
+newtype Restage = Restage Bool
+
+{- Restage pointer file. This is used after updating a worktree file
+ - when content is added/removed, to prevent git status from showing
+ - it as modified.
+ -
+ - Asks git to refresh its index information for the file.
+ - That in turn runs the clean filter on the file; when the clean
+ - filter produces the same pointer that was in the index before, git
+ - realizes that the file has not actually been modified.
+ -
+ - Note that, if the pointer file is staged for deletion, or has different
+ - content than the current worktree content staged, this won't change
+ - that. So it's safe to call at any time and any situation.
+ -
+ - If the index is known to be locked (eg, git add has run git-annex),
+ - that would fail. Restage False will prevent the index being updated.
+ - Will display a message to help the user understand why
+ - the file will appear to be modified.
+ -
+ - This uses the git queue, so the update is not performed immediately,
+ - and this can be run multiple times cheaply.
+ -
+ - The InodeCache is for the worktree file. It is used to detect when
+ - the worktree file is changed by something else before git update-index
+ - gets to look at it.
+ -}
+restagePointerFile :: Restage -> FilePath -> InodeCache -> Annex ()
+restagePointerFile (Restage False) f _ =
+ toplevelWarning True $ unableToRestage (Just f)
+restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
+ -- update-index is documented as picky about "./file" and it
+ -- fails on "../../repo/path/file" when cwd is not in the repo
+ -- being acted on. Avoid these problems with an absolute path.
+ absf <- liftIO $ absPath f
+ Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)]
+ where
+ isunmodified tsd = genInodeCache f tsd >>= return . \case
+ Nothing -> False
+ Just new -> compareStrong orig new
+
+ -- Other changes to the files may have been staged before this
+ -- gets a chance to run. To avoid a race with any staging of
+ -- changes, first lock the index file. Then run git update-index
+ -- on all still-unmodified files, using a copy of the index file,
+ -- to bypass the lock. Then replace the old index file with the new
+ -- updated index file.
+ runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do
+ realindex <- Git.Index.currentIndexFile r
+ let lock = Git.Index.indexFileLock realindex
+ lockindex = catchMaybeIO $ Git.LockFile.openLock' lock
+ unlockindex = maybe noop Git.LockFile.closeLock
+ showwarning = warningIO $ unableToRestage Nothing
+ go Nothing = showwarning
+ go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do
+ let tmpindex = tmpdir </> "index"
+ let updatetmpindex = do
+ r' <- Git.Env.addGitEnv r Git.Index.indexEnv
+ =<< Git.Index.indexEnvVal tmpindex
+ Git.UpdateIndex.refreshIndex r' $ \feed ->
+ forM_ l $ \(f', checkunmodified) ->
+ whenM checkunmodified $
+ feed f'
+ let replaceindex = catchBoolIO $ do
+ moveFile tmpindex realindex
+ return True
+ ok <- createLinkOrCopy realindex tmpindex
+ <&&> updatetmpindex
+ <&&> replaceindex
+ unless ok showwarning
+ bracket lockindex unlockindex go
+
+unableToRestage :: Maybe FilePath -> String
+unableToRestage mf = unwords
+ [ "git status will show " ++ fromMaybe "some files" mf
+ , "to be modified, since content availability has changed"
+ , "and git-annex was unable to update the index."
+ , "This is only a cosmetic problem affecting git status; git add,"
+ , "git commit, etc won't be affected."
+ , "To fix the git status display, you can run:"
+ , "git update-index -q --refresh " ++ fromMaybe "<file>" mf
+ ]
+
{- Parses a symlink target or a pointer file to a Key.
- Only looks at the first line, as pointer files can have subsequent
- lines. -}
diff --git a/Annex/Locations.hs b/Annex/Locations.hs
index bb45d8a..7e52dc6 100644
--- a/Annex/Locations.hs
+++ b/Annex/Locations.hs
@@ -33,6 +33,7 @@ module Annex.Locations (
gitAnnexUnusedLog,
gitAnnexKeysDb,
gitAnnexKeysDbLock,
+ gitAnnexKeysDbIndexCache,
gitAnnexFsckState,
gitAnnexFsckDbDir,
gitAnnexFsckDbLock,
@@ -285,6 +286,11 @@ gitAnnexKeysDb r = gitAnnexDir r </> "keys"
gitAnnexKeysDbLock :: Git.Repo -> FilePath
gitAnnexKeysDbLock r = gitAnnexKeysDb r ++ ".lck"
+{- Contains the stat of the last index file that was
+ - reconciled with rhe keys database. -}
+gitAnnexKeysDbIndexCache :: Git.Repo -> FilePath
+gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r ++ ".cache"
+
{- .git/annex/fsck/uuid/ is used to store information about incremental
- fscks. -}
gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath
diff --git a/Annex/Queue.hs b/Annex/Queue.hs
index 9c22e75..c5555ca 100644
--- a/Annex/Queue.hs
+++ b/Annex/Queue.hs
@@ -9,6 +9,7 @@
module Annex.Queue (
addCommand,
+ addInternalAction,
addUpdateIndex,
flush,
flushWhenFull,
@@ -22,6 +23,8 @@ import Annex hiding (new)
import qualified Git.Queue
import qualified Git.UpdateIndex
+import qualified Control.Concurrent.SSem as SSem
+
{- Adds a git command to the queue. -}
addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
addCommand command params files = do
@@ -29,6 +32,12 @@ addCommand command params files = do
store <=< flushWhenFull <=< inRepo $
Git.Queue.addCommand command params files q
+addInternalAction :: Git.Queue.InternalActionRunner -> [(FilePath, IO Bool)] -> Annex ()
+addInternalAction runner files = do
+ q <- get
+ store <=< flushWhenFull <=< inRepo $
+ Git.Queue.addInternalAction runner files q
+
{- Adds an update-index stream to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
addUpdateIndex streamer = do
@@ -49,10 +58,23 @@ flush = do
unless (0 == Git.Queue.size q) $ do
store =<< flush' q
+{- When there are multiple worker threads, each has its own queue.
+ -
+ - But, flushing two queues at the same time could lead to failures due to
+ - git locking files. So, only one queue is allowed to flush at a time.
+ - The repoqueuesem is shared between threads.
+ -}
flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue
-flush' q = do
- showStoringStateAction
- inRepo $ Git.Queue.flush q
+flush' q = bracket lock unlock go
+ where
+ lock = do
+ s <- getState repoqueuesem
+ liftIO $ SSem.wait s
+ return s
+ unlock = liftIO . SSem.signal
+ go _ = do
+ showStoringStateAction
+ inRepo $ Git.Queue.flush q
{- Gets the size of the queue. -}
size :: Annex Int
diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
index 06dfdf5..be12cbb 100644
--- a/Annex/ReplaceFile.hs
+++ b/Annex/ReplaceFile.hs
@@ -26,7 +26,7 @@ import Utility.Path.Max
-
- Throws an IO exception when it was unable to replace the file.
-}
-replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
+replaceFile :: FilePath -> (FilePath -> Annex a) -> Annex a
replaceFile file action = do
misctmpdir <- fromRepo gitAnnexTmpMiscDir
void $ createAnnexDirectory misctmpdir
@@ -43,8 +43,9 @@ replaceFile file action = do
#endif
withTmpDirIn misctmpdir basetmp $ \tmpdir -> do
let tmpfile = tmpdir </> basetmp
- action tmpfile
+ r <- action tmpfile
liftIO $ replaceFileFrom tmpfile file
+ return r
replaceFileFrom :: FilePath -> FilePath -> IO ()
replaceFileFrom src dest = go `catchIO` fallback
diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs
index 49007f9..28ba261 100644
--- a/Annex/YoutubeDl.hs
+++ b/Annex/YoutubeDl.hs
@@ -35,9 +35,10 @@ youtubeDlAllowed = httpAddressesUnlimited
youtubeDlNotAllowedMessage :: String
youtubeDlNotAllowedMessage = unwords
- [ "youtube-dl could potentially access any address, and the"
+ [ "This url is supported by youtube-dl, but"
+ , "youtube-dl could potentially access any address, and the"
, "configuration of annex.security.allowed-http-addresses"
- , "does not allow that."
+ , "does not allow that. Not using youtube-dl."
]
-- Runs youtube-dl in a work directory, to download a single media file
diff --git a/Backend/Hash.hs b/Backend/Hash.hs
index e4845b7..f9dddaa 100644
--- a/Backend/Hash.hs
+++ b/Backend/Hash.hs
@@ -18,9 +18,7 @@ import Types.Key
import Types.Backend
import Types.KeySource
import Utility.Hash
-import Utility.ExternalSHA
-import qualified BuildInfo
import qualified Data.ByteString.Lazy as L
import Data.Char
@@ -89,7 +87,7 @@ keyValue :: Hash -> KeySource -> Annex (Maybe Key)
keyValue hash source = do
let file = contentLocation source
filesize <- liftIO $ getFileSize file
- s <- hashFile hash file filesize
+ s <- hashFile hash file
return $ Just $ stubKey
{ keyName = s
, keyVariety = hashKeyVariety hash (HasExt False)
@@ -116,16 +114,16 @@ selectExtension f
reverse $ splitc '.' $ takeExtensions f
shortenough e = length e <= 4 -- long enough for "jpeg"
-{- A key's checksum is checked during fsck. -}
+{- A key's checksum is checked during fsck when it's content is present
+ - except for in fast mode. -}
checkKeyChecksum :: Hash -> Key -> FilePath -> Annex Bool
checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do
fast <- Annex.getState Annex.fast
- mstat <- liftIO $ catchMaybeIO $ getFileStatus file
- case (mstat, fast) of
- (Just stat, False) -> do
- filesize <- liftIO $ getFileSize' file stat
+ exists <- liftIO $ doesFileExist file
+ case (exists, fast) of
+ (True, False) -> do
showAction "checksum"
- check <$> hashFile hash file filesize
+ check <$> hashFile hash file
_ -> return True
where
expected = keyHash key
@@ -192,55 +190,33 @@ trivialMigrate oldkey newbackend afile
oldvariety = keyVariety oldkey
newvariety = backendVariety newbackend
-hashFile :: Hash -> FilePath -> Integer -> Annex String
-hashFile hash file filesize = go hash
+hashFile :: Hash -> FilePath -> Annex String
+hashFile hash file = liftIO $ do
+ h <- hasher <$> L.readFile file
+ -- Force full evaluation so file is read and closed.
+ return (length h `seq` h)
where
- go MD5Hash = use md5Hasher
- go SHA1Hash = usehasher (HashSize 1)
- go (SHA2Hash hashsize) = usehasher hashsize
- go (SHA3Hash hashsize) = use (sha3Hasher hashsize)
- go (SkeinHash hashsize) = use (skeinHasher hashsize)
+ hasher = case hash of
+ MD5Hash -> md5Hasher
+ SHA1Hash -> sha1Hasher
+ SHA2Hash hashsize -> sha2Hasher hashsize
+ SHA3Hash hashsize -> sha3Hasher hashsize
+ SkeinHash hashsize -> skeinHasher hashsize
#if MIN_VERSION_cryptonite(0,23,0)
- go (Blake2bHash hashsize) = use (blake2bHasher hashsize)
- go (Blake2sHash hashsize) = use (blake2sHasher hashsize)
- go (Blake2spHash hashsize) = use (blake2spHasher hashsize)
+ Blake2bHash hashsize -> blake2bHasher hashsize
+ Blake2sHash hashsize -> blake2sHasher hashsize
+ Blake2spHash hashsize -> blake2spHasher hashsize
#endif
-
- use hasher = liftIO $ do
- h <- hasher <$> L.readFile file
- -- Force full evaluation so file is read and closed.
- return (length h `seq` h)
-
- usehasher hashsize@(HashSize sz) = case shaHasher hashsize filesize of
- Left sha -> use sha
- Right (external, internal) ->
- liftIO (externalSHA external sz file) >>= \case
- Right r -> return r
- Left e -> do
- warning e
- -- fall back to internal since
- -- external command failed
- use internal
-shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) (String, L.ByteString -> String)
-shaHasher (HashSize hashsize) filesize
- | hashsize == 1 = use BuildInfo.sha1 sha1
- | hashsize == 256 = use BuildInfo.sha256 sha2_256
- | hashsize == 224 = use BuildInfo.sha224 sha2_224
- | hashsize == 384 = use BuildInfo.sha384 sha2_384
- | hashsize == 512 = use BuildInfo.sha512 sha2_512
+sha2Hasher :: HashSize -> (L.ByteString -> String)
+sha2Hasher (HashSize hashsize)
+ | hashsize == 256 = use sha2_256
+ | hashsize == 224 = use sha2_224
+ | hashsize == 384 = use sha2_384
+ | hashsize == 512 = use sha2_512
| otherwise = error $ "unsupported SHA size " ++ show hashsize
where
- use Nothing hasher = Left $ usehasher hasher
- use (Just c) hasher
- {- Use builtin, but slightly slower hashing for
- - smallish files. Cryptohash benchmarks 90 to 101%
- - faster than external hashers, depending on the hash
- - and system. So there is no point forking an external
- - process unless the file is large. -}
- | filesize < 1048576 = Left $ usehasher hasher
- | otherwise = Right (c, usehasher hasher)
- usehasher hasher = show . hasher
+ use hasher = show . hasher
sha3Hasher :: HashSize -> (L.ByteString -> String)
sha3Hasher (HashSize hashsize)
@@ -280,6 +256,9 @@ blake2spHasher (HashSize hashsize)
| otherwise = error $ "unsupported BLAKE2SP size " ++ show hashsize
#endif
+sha1Hasher :: L.ByteString -> String
+sha1Hasher = show . sha1
+
md5Hasher :: L.ByteString -> String
md5Hasher = show . md5
diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs
index cf16da0..f593c98 100644
--- a/Build/BundledPrograms.hs
+++ b/Build/BundledPrograms.hs
@@ -75,13 +75,8 @@ preferredBundledPrograms = catMaybes
, BuildInfo.lsof
, BuildInfo.gcrypt
#ifndef mingw32_HOST_OS
- -- All these utilities are included in git for Windows
+ -- These utilities are included in git for Windows
, ifset BuildInfo.curl "curl"
- , BuildInfo.sha1
- , BuildInfo.sha256
- , BuildInfo.sha512
- , BuildInfo.sha224
- , BuildInfo.sha384
, Just "cp"
#endif
#ifdef linux_HOST_OS
diff --git a/Build/Configure.hs b/Build/Configure.hs
index c490148..6157921 100644
--- a/Build/Configure.hs
+++ b/Build/Configure.hs
@@ -7,7 +7,6 @@ module Build.Configure where
import Build.TestConfig
import Build.Version
import Utility.SafeCommand
-import Utility.ExternalSHA
import Utility.Env.Basic
import qualified Git.Version
import Utility.Directory
@@ -38,38 +37,8 @@ tests =
, TestCase "lsof" $ findCmdPath "lsof" "lsof"
, TestCase "git-remote-gcrypt" $ findCmdPath "gcrypt" "git-remote-gcrypt"
, TestCase "ssh connection caching" getSshConnectionCaching
- ] ++ shaTestCases
- [ (1, "da39a3ee5e6b4b0d3255bfef95601890afd80709")
- , (256, "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
- , (512, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")
- , (224, "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f")
- , (384, "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b")
]
-{- shaNsum are the program names used by coreutils. Some systems
- - install these with 'g' prefixes.
- -
- - On some systems, shaN is used instead, but on other
- - systems, it might be "hashalot", which does not produce
- - usable checksums. Only accept programs that produce
- - known-good hashes when run on files. -}
-shaTestCases :: [(Int, String)] -> [TestCase]
-shaTestCases l = map make l
- where
- make (n, knowngood) = TestCase key $
- Config key . MaybeStringConfig <$> search (shacmds n)
- where
- key = "sha" ++ show n
- search [] = return Nothing
- search (c:cmds) = do
- sha <- externalSHA c n "/dev/null"
- if sha == Right knowngood
- then return $ Just c
- else search cmds
-
- shacmds n = concatMap (\x -> [x, 'g':x]) $
- map (\x -> "sha" ++ show n ++ x) ["sum", ""]
-
tmpDir :: String
tmpDir = "tmp"
@@ -128,8 +97,6 @@ androidConfig c = overrides ++ filter (not . overridden) c
overrides =
[ Config "cp_reflink_auto" $ BoolConfig False
, Config "curl" $ BoolConfig False
- , Config "sha224" $ MaybeStringConfig Nothing
- , Config "sha384" $ MaybeStringConfig Nothing
]
overridden (Config k _) = k `elem` overridekeys
overridekeys = map (\(Config k _) -> k) overrides
diff --git a/CHANGELOG b/CHANGELOG
index 2b011e0..0206702 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,54 @@
+git-annex (6.20180913) upstream; urgency=medium
+
+ * When --batch is used with matching options like --in, --metadata,
+ etc, only operate on the provided files when they match those options.
+ Otherwise, a blank line is output in the batch protocol.
+ Affected commands: find, add, whereis, drop, copy, move, get
+ * Make metadata --batch combined with matching options refuse to run,
+ since it does not seem worth supporting that combination.
+ * v6 add: Take advantage of improved SIGPIPE handler in git 2.5 to
+ speed up the clean filter by not reading the file content from the
+ pipe. This also avoids git buffering the whole file content in memory.
+ * v6: After updating the worktree for an add/drop, update git's index,
+ so git status will not show the files as modified.
+ * v6: When annex.largefiles is not configured for a file, running git
+ add or git commit, or otherwise using git to stage a file
+ will add it to the annex if the file was in the annex before,
+ and to git otherwise. This is to avoid accidental conversion.
+ Note that git-annex add's behavior has not changed.
+ * v6: Update associated files database when git has staged changes
+ to pointer files.
+ * v6: Fix some race conditions.
+ * v6: Fix annex object file permissions when git-annex add is run
+ on a modified unlocked file, and in some related cases.
+ * v6: When a file is unlocked but has not been modified,
+ and the unlocking is only staged, git-annex add did not lock it.
+ Now it will, for consistency with how modified files are handled and
+ with v5.
+ * Fix git command queue to be concurrency safe.
+ * linux standalone: When LOCPATH is already set, use it instead of the
+ bundled locales. It can be set to an empty string to use the system
+ locales too.
+ * Stop using external hash programs, since cryptonite is faster.
+ * Fix build on FreeBSD.
+ * S3: Support buckets with versioning enabled. When a remote
+ is configured with exporttree=yes versioning=yes, git-annex can
+ download past versions of exported files from it.
+ * S3: Multipart uploads are now only supported when git-annex is built
+ with aws-0.16.0 or later, as earlier versions of the library don't
+ support versioning with multipart uploads.
+ * S3: Support AWS_SESSION_TOKEN.
+ * Don't use GIT_PREFIX when GIT_WORK_TREE=. because it seems git
+ does not intend GIT_WORK_TREE to be relative to GIT_PREFIX in that
+ case, despite GIT_WORK_TREE=.. being relative to GIT_PREFIX.
+ * Don't use GIT_PREFIX to fix up a relative GIT_DIR, because
+ git 2.11 sets GIT_PREFIX to a path it's not relative to.
+ and apparently GIT_DIR is never relative to GIT_PREFIX.
+ * git-annex.cabal: Fix build without assistant, and some other refinements.
+ Thanks fftehnik.
+
+ -- Joey Hess <id@joeyh.name> Thu, 13 Sep 2018 15:50:38 -0400
+
git-annex (6.20180807) upstream; urgency=medium
* S3: Support credential-less download from remotes configured
diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs
index 8203831..cea108f 100644
--- a/CmdLine/Batch.hs
+++ b/CmdLine/Batch.hs
@@ -12,6 +12,8 @@ import Types.Command
import CmdLine.Action
import CmdLine.GitAnnex.Options
import Options.Applicative
+import Limit
+import Types.FileMatcher
data BatchMode = Batch | NoBatch
@@ -72,5 +74,18 @@ batchCommandAction a = maybe (batchBadInput Batch) (const noop)
-- Reads lines of batch input and passes the filepaths to a CommandStart
-- to handle them.
-batchFiles :: (FilePath -> CommandStart) -> Annex ()
-batchFiles a = batchInput Right $ batchCommandAction . a
+--
+-- File matching options are not checked.
+allBatchFiles :: (FilePath -> CommandStart) -> Annex ()
+allBatchFiles a = batchInput Right $ batchCommandAction . a
+
+-- Like allBatchFiles, but checks the file matching options
+-- and skips non-matching files.
+batchFilesMatching :: (FilePath -> CommandStart) -> Annex ()
+batchFilesMatching a = do
+ matcher <- getMatcher
+ allBatchFiles $ \f ->
+ ifM (matcher $ MatchingFile $ FileInfo f f)
+ ( a f
+ , return Nothing
+ )
diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs
index ec002db..a778a1e 100644
--- a/CmdLine/Seek.hs
+++ b/CmdLine/Seek.hs
@@ -4,7 +4,7 @@
- the values a user passes to a command, and prepare actions operating
- on them.
-
- - Copyright 2010-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -31,6 +31,8 @@ import Remote.List
import qualified Remote
import Annex.CatFile
import Annex.Content
+import Annex.InodeSentinal
+import qualified Database.Keys
withFilesInGit :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
withFilesInGit a l = seekActions $ prepFiltered a $
@@ -128,9 +130,6 @@ withFilesToBeCommitted a l = seekActions $ prepFiltered a $
withFilesOldUnlocked :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
withFilesOldUnlocked = withFilesOldUnlocked' LsFiles.typeChanged
-withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
-withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged
-
{- Unlocked files before v6 have changed type from a symlink to a regular file.
-
- Furthermore, unlocked files used to be a git-annex symlink,
@@ -146,6 +145,23 @@ isOldUnlocked :: FilePath -> Annex Bool
isOldUnlocked f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
+withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
+withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged
+
+{- v6 unlocked pointer files that are staged, and whose content has not been
+ - modified-}
+withUnmodifiedUnlockedPointers :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
+withUnmodifiedUnlockedPointers a l = seekActions $
+ prepFiltered a unlockedfiles
+ where
+ unlockedfiles = filterM isV6UnmodifiedUnlocked
+ =<< seekHelper LsFiles.typeChangedStaged l
+
+isV6UnmodifiedUnlocked :: FilePath -> Annex Bool
+isV6UnmodifiedUnlocked f = catKeyFile f >>= \case
+ Nothing -> return False
+ Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
+
{- Finds files that may be modified. -}
withFilesMaybeModified :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
withFilesMaybeModified a params = seekActions $
diff --git a/Command/Add.hs b/Command/Add.hs
index 10148ad..a89ef3d 100644
--- a/Command/Add.hs
+++ b/Command/Add.hs
@@ -62,15 +62,18 @@ seek o = allowConcurrentOutput $ do
Batch
| updateOnly o ->
giveup "--update --batch is not supported"
- | otherwise -> batchFiles gofile
+ | otherwise -> batchFilesMatching gofile
NoBatch -> do
l <- workTreeItems (addThese o)
let go a = a gofile l
unless (updateOnly o) $
go (withFilesNotInGit (not $ includeDotFiles o))
go withFilesMaybeModified
- unlessM (versionSupportsUnlockedPointers <||> isDirect) $
- go withFilesOldUnlocked
+ ifM versionSupportsUnlockedPointers
+ ( go withUnmodifiedUnlockedPointers
+ , unlessM isDirect $
+ go withFilesOldUnlocked
+ )
{- Pass file off to git-add. -}
startSmall :: FilePath -> CommandStart
@@ -111,8 +114,7 @@ start file = do
addpresent key = ifM versionSupportsUnlockedPointers
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
Just s | isSymbolicLink s -> fixuplink key
- _ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key)
- ( stop, add )
+ _ -> add
, ifM isDirect
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
Just s | isSymbolicLink s -> fixuplink key
diff --git a/Command/Copy.hs b/Command/Copy.hs
index daf2e66..d3248f4 100644
--- a/Command/Copy.hs
+++ b/Command/Copy.hs
@@ -47,7 +47,7 @@ seek :: CopyOptions -> CommandSeek
seek o = allowConcurrentOutput $ do
let go = whenAnnexed $ start o
case batchOption o of
- Batch -> batchInput Right (batchCommandAction . go)
+ Batch -> batchFilesMatching go
NoBatch -> withKeyOptions
(keyOptions o) (autoMode o)
(Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever)
diff --git a/Command/Drop.hs b/Command/Drop.hs
index baeae66..4d7f13f 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -54,7 +54,7 @@ parseDropFromOption = parseRemoteOption <$> strOption
seek :: DropOptions -> CommandSeek
seek o = allowConcurrentOutput $
case batchOption o of
- Batch -> batchInput Right (batchCommandAction . go)
+ Batch -> batchFilesMatching go
NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
(startKeys o)
(withFilesInGit go)
diff --git a/Command/Export.hs b/Command/Export.hs
index 5084e4f..0cb202f 100644
--- a/Command/Export.hs
+++ b/Command/Export.hs
@@ -285,11 +285,15 @@ cleanupUnexport r ea db eks loc = do
removeExportedLocation db (asKey ek) loc
flushDbQueue db
- remaininglocs <- liftIO $
- concat <$> forM eks (\ek -> getExportedLocation db (asKey ek))
- when (null remaininglocs) $
- forM_ eks $ \ek ->
- logChange (asKey ek) (uuid r) InfoMissing
+ -- An appendonly remote can support removeExportLocation to remove
+ -- the file from the exported tree, but still retain the content
+ -- and allow retrieving it.
+ unless (appendonly r) $ do
+ remaininglocs <- liftIO $
+ concat <$> forM eks (\ek -> getExportedLocation db (asKey ek))
+ when (null remaininglocs) $
+ forM_ eks $ \ek ->
+ logChange (asKey ek) (uuid r) InfoMissing
removeEmptyDirectories ea db loc (map asKey eks)
diff --git a/Command/Find.hs b/Command/Find.hs
index 10eff35..9d7c040 100644
--- a/Command/Find.hs
+++ b/Command/Find.hs
@@ -51,7 +51,7 @@ parseFormatOption =
seek :: FindOptions -> CommandSeek
seek o = case batchOption o of
NoBatch -> withFilesInGit go =<< workTreeItems (findThese o)
- Batch -> batchFiles go
+ Batch -> batchFilesMatching go
where
go = whenAnnexed $ start o
diff --git a/Command/Get.hs b/Command/Get.hs
index eac8e88..fde65c5 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -42,7 +42,7 @@ seek o = allowConcurrentOutput $ do
from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
let go = whenAnnexed $ start o from
case batchOption o of
- Batch -> batchInput Right (batchCommandAction . go)
+ Batch -> batchFilesMatching go
NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
(startKeys from)
(withFilesInGit go)
diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs
index ce02cfa..6409e17 100644
--- a/Command/ImportFeed.hs
+++ b/Command/ImportFeed.hs
@@ -85,7 +85,7 @@ perform opts cache url = do
showOutput
ok <- and <$> mapM (performDownload opts cache) l
unless ok $
- feedProblem url "problem downloading item"
+ feedProblem url "problem downloading some item(s) from feed"
next $ cleanup url True
cleanup :: URLString -> Bool -> CommandCleanup
@@ -198,7 +198,7 @@ performDownload opts cache todownload = case location todownload of
let mediaurl = setDownloader linkurl YoutubeDownloader
let mediakey = Backend.URL.fromUrl mediaurl Nothing
-- Old versions of git-annex that used quvi might have
- -- used the quviurl for this, so check i/f it's known
+ -- used the quviurl for this, so check if it's known
-- to avoid adding it a second time.
let quviurl = setDownloader linkurl QuviDownloader
checkknown mediaurl $ checkknown quviurl $
diff --git a/Command/MetaData.hs b/Command/MetaData.hs
index 282b7fd..1e9e434 100644
--- a/Command/MetaData.hs
+++ b/Command/MetaData.hs
@@ -15,6 +15,7 @@ import Annex.WorkTree
import Messages.JSON (JSONActionItem(..))
import Types.Messages
import Utility.Aeson
+import Limit
import qualified Data.Set as S
import qualified Data.Map as M
@@ -83,8 +84,11 @@ seek o = case batchOption o of
(seeker $ whenAnnexed $ start c o)
=<< workTreeItems (forFiles o)
Batch -> withMessageState $ \s -> case outputType s of
- JSONOutput _ -> batchInput parseJSONInput $
- commandAction . startBatch
+ JSONOutput _ -> ifM limited
+ ( giveup "combining --batch with file matching options is not currently supported"
+ , batchInput parseJSONInput $
+ commandAction . startBatch
+ )
_ -> giveup "--batch is currently only supported in --json mode"
start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart
@@ -108,7 +112,7 @@ perform c o k = case getSet o of
Set ms -> do
oldm <- getCurrentMetaData k
let m = combineMetaData $ map (modMeta oldm) ms
- addMetaData' k m c
+ addMetaDataClocked k m c
next $ cleanup k
_ -> next $ cleanup k
diff --git a/Command/Move.hs b/Command/Move.hs
index b50c877..f5de2c9 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -57,7 +57,7 @@ seek :: MoveOptions -> CommandSeek
seek o = allowConcurrentOutput $ do
let go = whenAnnexed $ start (fromToOptions o) (removeWhen o)
case batchOption o of
- Batch -> batchInput Right (batchCommandAction . go)
+ Batch -> batchFilesMatching go
NoBatch -> withKeyOptions (keyOptions o) False
(startKey (fromToOptions o) (removeWhen o))
(withFilesInGit go)
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
index 4de6e96..647f31a 100644
--- a/Command/ReKey.hs
+++ b/Command/ReKey.hs
@@ -85,7 +85,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
- and vulnerable to corruption. -}
( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do
oldobj <- calcRepo (gitAnnexLocation oldkey)
- linkOrCopy' (return True) newkey oldobj tmp Nothing
+ isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing
, do
ic <- withTSDelta (liftIO . genInodeCache file)
{- The file being rekeyed is itself an unlocked file, so if
diff --git a/Command/Reinject.hs b/Command/Reinject.hs
index bde4c81..428cccf 100644
--- a/Command/Reinject.hs
+++ b/Command/Reinject.hs
@@ -47,7 +47,7 @@ startSrcDest (src:dest:[])
where
go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
( perform src key
- , error "failed"
+ , giveup $ src ++ " does not have expected content of " ++ dest
)
startSrcDest _ = giveup "specify a src file and a dest file"
diff --git a/Command/Smudge.hs b/Command/Smudge.hs
index 1644ee2..28dc551 100644
--- a/Command/Smudge.hs
+++ b/Command/Smudge.hs
@@ -1,6 +1,6 @@
{- git-annex command
-
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -16,7 +16,9 @@ import Annex.Ingest
import Annex.CatFile
import Logs.Location
import qualified Database.Keys
+import qualified Git.BuildVersion
import Git.FilePath
+import qualified Git.Ref
import Backend
import qualified Data.ByteString.Lazy as B
@@ -68,45 +70,85 @@ smudge file = do
-- Clean filter is fed file content on stdin, decides if a file
-- should be stored in the annex, and outputs a pointer to its
--- injested content.
+-- injested content if so. Otherwise, the original content.
clean :: FilePath -> CommandStart
clean file = do
b <- liftIO $ B.hGetContents stdin
- if isJust (parseLinkOrPointer b)
- then liftIO $ B.hPut stdout b
- else ifM (shouldAnnex file)
- ( do
- -- Even though we ingest the actual file,
- -- and not stdin, we need to consume all
- -- stdin, or git will get annoyed.
- B.length b `seq` return ()
- -- Look up the backend that was used
- -- for this file before, so that when
- -- git re-cleans a file its backend does
- -- not change.
- currbackend <- maybe Nothing (maybeLookupBackendVariety . keyVariety)
- <$> catKeyFile file
- liftIO . emitPointer
- =<< go
- =<< (\ld -> ingest' currbackend ld Nothing)
- =<< lockDown cfg file
- , liftIO $ B.hPut stdout b
- )
+ case parseLinkOrPointer b of
+ Just k -> do
+ getMoveRaceRecovery k file
+ liftIO $ B.hPut stdout b
+ Nothing -> go b =<< catKeyFile file
stop
where
- go (Just k, _) = do
+ go b oldkey = ifM (shouldAnnex file oldkey)
+ ( do
+ -- Before git 2.5, failing to consume all stdin here
+ -- would cause a SIGPIPE and crash it.
+ -- Newer git catches the signal and stops sending,
+ -- which is much faster. (Also, git seems to forget
+ -- to free memory when sending the file, so the
+ -- less we let it send, the less memory it will waste.)
+ if Git.BuildVersion.older "2.5"
+ then B.length b `seq` return ()
+ else liftIO $ hClose stdin
+ -- Look up the backend that was used for this file
+ -- before, so that when git re-cleans a file its
+ -- backend does not change.
+ let oldbackend = maybe Nothing (maybeLookupBackendVariety . keyVariety) oldkey
+ -- Can't restage associated files because git add
+ -- runs this and has the index locked.
+ let norestage = Restage False
+ liftIO . emitPointer
+ =<< postingest
+ =<< (\ld -> ingest' oldbackend ld Nothing norestage)
+ =<< lockDown cfg file
+ , liftIO $ B.hPut stdout b
+ )
+
+ postingest (Just k, _) = do
logStatus k InfoPresent
return k
- go _ = error "could not add file to the annex"
+ postingest _ = error "could not add file to the annex"
+
cfg = LockDownConfig
{ lockingFile = False
, hardlinkFileTmp = False
}
-shouldAnnex :: FilePath -> Annex Bool
-shouldAnnex file = do
+-- New files are annexed as configured by annex.largefiles, with a default
+-- of annexing them.
+--
+-- If annex.largefiles is not configured for a file, and a file with its
+-- name is already in the index, preserve its annexed/not annexed state.
+-- This prevents accidental conversions when annex.largefiles is being
+-- set/unset on the fly rather than being set in gitattributes or .git/config.
+shouldAnnex :: FilePath -> Maybe Key -> Annex Bool
+shouldAnnex file moldkey = do
matcher <- largeFilesMatcher
- checkFileMatcher matcher file
+ checkFileMatcher' matcher file whenempty
+ where
+ whenempty = case moldkey of
+ Just _ -> return True
+ Nothing -> isNothing <$> catObjectMetaData (Git.Ref.fileRef file)
emitPointer :: Key -> IO ()
emitPointer = putStr . formatPointer
+
+-- Recover from a previous race between eg git mv and git-annex get.
+-- That could result in the file remaining a pointer file, while
+-- its content is present in the annex. Populate the pointer file.
+--
+-- This also handles the case where a copy of a pointer file is made,
+-- then git-annex gets the content, and later git add is run on
+-- the pointer copy. It will then be populated with the content.
+getMoveRaceRecovery :: Key -> FilePath -> Annex ()
+getMoveRaceRecovery k file = void $ tryNonAsync $
+ liftIO (isPointerFile file) >>= \k' -> when (Just k == k') $
+ whenM (inAnnex k) $ do
+ obj <- calcRepo (gitAnnexLocation k)
+ -- Cannot restage because git add is running and has
+ -- the index locked.
+ populatePointerFile (Restage False) k obj file >>= \case
+ Nothing -> return ()
+ Just ic -> Database.Keys.addInodeCaches k [ic]
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
index b14e231..988c4aa 100644
--- a/Command/Whereis.hs
+++ b/Command/Whereis.hs
@@ -40,7 +40,7 @@ seek o = do
m <- remoteMap id
let go = whenAnnexed $ start m
case batchOption o of
- Batch -> batchFiles go
+ Batch -> batchFilesMatching go
NoBatch ->
withKeyOptions (keyOptions o) False
(startKeys m)
diff --git a/Config.hs b/Config.hs
index 6680857..94d67ce 100644
--- a/Config.hs
+++ b/Config.hs
@@ -102,21 +102,3 @@ setCrippledFileSystem :: Bool -> Annex ()
setCrippledFileSystem b = do
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b }
-
-configureSmudgeFilter :: Annex ()
-configureSmudgeFilter = do
- setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge %f"
- setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean %f"
- lf <- Annex.fromRepo Git.attributesLocal
- gf <- Annex.fromRepo Git.attributes
- lfs <- readattr lf
- gfs <- readattr gf
- liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
- createDirectoryIfMissing True (takeDirectory lf)
- writeFile lf (lfs ++ "\n" ++ stdattr)
- where
- readattr = liftIO . catchDefaultIO "" . readFileStrict
- stdattr = unlines
- [ "* filter=annex"
- , ".* !filter"
- ]
diff --git a/Config/Smudge.hs b/Config/Smudge.hs
new file mode 100644
index 0000000..3ef7d4b
--- /dev/null
+++ b/Config/Smudge.hs
@@ -0,0 +1,41 @@
+{- Git smudge filter configuration
+ -
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Config.Smudge where
+
+import Annex.Common
+import qualified Annex
+import qualified Git
+import qualified Git.Command
+import Config
+
+configureSmudgeFilter :: Annex ()
+configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
+ -- If this is run in a newly cloned repository, git may not have
+ -- cached file information in the index yet, and so after
+ -- configuring the clean filter, the next git status would want to
+ -- run it on every file. That is expensive and can also result in
+ -- unexpected changes when the file is checked into git or annex
+ -- counter to the annex.largefiles configuration.
+ -- Avoid that problem by running git status now.
+ inRepo $ Git.Command.runQuiet [Param "status", Param "--porcelain"]
+
+ setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge %f"
+ setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean %f"
+ lf <- Annex.fromRepo Git.attributesLocal
+ gf <- Annex.fromRepo Git.attributes
+ lfs <- readattr lf
+ gfs <- readattr gf
+ liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
+ createDirectoryIfMissing True (takeDirectory lf)
+ writeFile lf (lfs ++ "\n" ++ stdattr)
+ where
+ readattr = liftIO . catchDefaultIO "" . readFileStrict
+ stdattr = unlines
+ [ "* filter=annex"
+ , ".* !filter"
+ ]
diff --git a/Database/Keys.hs b/Database/Keys.hs
index 282da9f..0456ce7 100644
--- a/Database/Keys.hs
+++ b/Database/Keys.hs
@@ -1,6 +1,6 @@
{- Sqlite database of information about Keys
-
- - Copyright 2015-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -15,6 +15,7 @@ module Database.Keys (
getAssociatedKey,
removeAssociatedFile,
storeInodeCaches,
+ storeInodeCaches',
addInodeCaches,
getInodeCaches,
removeInodeCaches,
@@ -31,9 +32,16 @@ import Annex.Common hiding (delete)
import Annex.Version (versionUsesKeysDatabase)
import qualified Annex
import Annex.LockFile
+import Annex.CatFile
+import Annex.Content.PointerFile
+import Annex.Link
import Utility.InodeCache
import Annex.InodeSentinal
+import Git
import Git.FilePath
+import Git.Command
+import Git.Types
+import Git.Index
{- Runs an action that reads from the database.
-
@@ -124,12 +132,16 @@ openDb createdb _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKe
open db
(False, False) -> return DbUnavailable
where
- open db = liftIO $ DbOpen <$> H.openDbQueue H.MultiWriter db SQL.containedTable
-- If permissions don't allow opening the database, treat it as if
-- it does not exist.
permerr e = case createdb of
False -> return DbUnavailable
True -> throwM e
+
+ open db = do
+ qh <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable
+ reconcileStaged qh
+ return $ DbOpen qh
{- Closes the database if it was open. Any writes will be flushed to it.
-
@@ -159,8 +171,12 @@ removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k)
{- Stats the files, and stores their InodeCaches. -}
storeInodeCaches :: Key -> [FilePath] -> Annex ()
-storeInodeCaches k fs = withTSDelta $ \d ->
- addInodeCaches k . catMaybes =<< liftIO (mapM (`genInodeCache` d) fs)
+storeInodeCaches k fs = storeInodeCaches' k fs []
+
+storeInodeCaches' :: Key -> [FilePath] -> [InodeCache] -> Annex ()
+storeInodeCaches' k fs ics = withTSDelta $ \d ->
+ addInodeCaches k . (++ ics) . catMaybes
+ =<< liftIO (mapM (`genInodeCache` d) fs)
addInodeCaches :: Key -> [InodeCache] -> Annex ()
addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is
@@ -172,3 +188,116 @@ getInodeCaches = runReaderIO . SQL.getInodeCaches . toIKey
removeInodeCaches :: Key -> Annex ()
removeInodeCaches = runWriterIO . SQL.removeInodeCaches . toIKey
+
+{- Looks at staged changes to find when unlocked files are copied/moved,
+ - and updates associated files in the keys database.
+ -
+ - Since staged changes can be dropped later, does not remove any
+ - associated files; only adds new associated files.
+ -
+ - This needs to be run before querying the keys database so that
+ - information is consistent with the state of the repository.
+ -
+ - To avoid unncessary work, the index file is statted, and if it's not
+ - changed since last time this was run, nothing is done.
+ -
+ - Note that this is run with a lock held, so only one process can be
+ - running this at a time.
+ -
+ - This also cleans up after a race between eg a git mv and git-annex
+ - get/drop/similar. If git moves the file between this being run and the
+ - get/drop, the moved file won't be updated for the get/drop.
+ - The next time this runs, it will see the staged change. It then checks
+ - if the worktree file's content availability does not match the git-annex
+ - content availablity, and makes changes as necessary to reconcile them.
+ -
+ - Note that if a commit happens before this runs again, it won't see
+ - the staged change. Instead, during the commit, git will run the clean
+ - filter. If a drop missed the file then the file is added back into the
+ - annex. If a get missed the file then the clean filter populates the
+ - file.
+ -}
+reconcileStaged :: H.DbQueue -> Annex ()
+reconcileStaged qh = whenM versionUsesKeysDatabase $ do
+ gitindex <- inRepo currentIndexFile
+ indexcache <- fromRepo gitAnnexKeysDbIndexCache
+ withTSDelta (liftIO . genInodeCache gitindex) >>= \case
+ Just cur ->
+ liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case
+ Nothing -> go cur indexcache
+ Just prev -> ifM (compareInodeCaches prev cur)
+ ( noop
+ , go cur indexcache
+ )
+ Nothing -> noop
+ where
+ go cur indexcache = do
+ (l, cleanup) <- inRepo $ pipeNullSplit diff
+ changed <- procdiff l False
+ void $ liftIO cleanup
+ -- Flush database changes immediately
+ -- so other processes can see them.
+ when changed $
+ liftIO $ H.flushDbQueue qh
+ liftIO $ writeFile indexcache $ showInodeCache cur
+
+ diff =
+ -- Avoid using external diff command, which would be slow.
+ -- (The -G option may make it be used otherwise.)
+ [ Param "-c", Param "diff.external="
+ -- Avoid running smudge or clean filters, since we want the
+ -- raw output, and they would block trying to access the
+ -- locked database. The --raw normally avoids git diff
+ -- running them, but older versions of git need this.
+ , Param "-c", Param "filter.annex.smudge="
+ , Param "-c", Param "filter.annex.clean="
+ , Param "diff"
+ , Param "--cached"
+ , Param "--raw"
+ , Param "-z"
+ , Param "--abbrev=40"
+ -- Optimization: Only find pointer files. This is not
+ -- perfect. A file could start with this and not be a
+ -- pointer file. And a pointer file that is replaced with
+ -- a non-pointer file will match this.
+ , Param $ "-G^" ++ toInternalGitPath (pathSeparator:objectDir)
+ -- Don't include files that were deleted, because this only
+ -- wants to update information for files that are present
+ -- in the index.
+ , Param "--diff-filter=AMUT"
+ -- Disable rename detection.
+ , Param "--no-renames"
+ -- Avoid other complications.
+ , Param "--ignore-submodules=all"
+ , Param "--no-ext-diff"
+ ]
+
+ procdiff (info:file:rest) changed = case words info of
+ ((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])
+ -- Only want files, not symlinks
+ | dstmode /= fmtTreeItemType TreeSymlink -> do
+ maybe noop (reconcile (asTopFilePath file))
+ =<< catKey (Ref dstsha)
+ procdiff rest True
+ | otherwise -> procdiff rest changed
+ _ -> return changed -- parse failed
+ procdiff _ changed = return changed
+
+ -- Note that database writes done in here will not necessarily
+ -- be visible to database reads also done in here.
+ reconcile file key = do
+ let ikey = toIKey key
+ liftIO $ SQL.addAssociatedFileFast ikey file (SQL.WriteHandle qh)
+ caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh)
+ keyloc <- calcRepo (gitAnnexLocation key)
+ keypopulated <- sameInodeCache keyloc caches
+ p <- fromRepo $ fromTopFilePath file
+ filepopulated <- sameInodeCache p caches
+ case (keypopulated, filepopulated) of
+ (True, False) ->
+ populatePointerFile (Restage True) key keyloc p >>= \case
+ Nothing -> return ()
+ Just ic -> liftIO $
+ SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh)
+ (False, True) -> depopulatePointerFile key p
+ _ -> return ()
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 2eca12f..82fd0c6 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -28,17 +28,17 @@ import Utility.Env.Set
-
- Also works around a git bug when running some hooks. It
- runs the hooks in the top of the repository, but if GIT_WORK_TREE
- - was relative, it then points to the wrong directory. In this situation
- - GIT_PREFIX contains the directory that GIT_WORK_TREE (and GIT_DIR)
- - are relative to.
+ - was relative (but not "."), it then points to the wrong directory.
+ - In this situation GIT_PREFIX contains the directory that
+ - GIT_WORK_TREE is relative to.
-}
get :: IO Repo
get = do
- prefix <- getpathenv "GIT_PREFIX"
- gd <- pathenv "GIT_DIR" prefix
+ gd <- getpathenv "GIT_DIR"
r <- configure gd =<< fromCwd
+ prefix <- getpathenv "GIT_PREFIX"
wt <- maybe (worktree $ location r) Just
- <$> pathenv "GIT_WORK_TREE" prefix
+ <$> getpathenvprefix "GIT_WORK_TREE" prefix
case wt of
Nothing -> return r
Just d -> do
@@ -55,10 +55,13 @@ get = do
return (Just d)
Nothing -> return Nothing
- pathenv s Nothing = getpathenv s
- pathenv s (Just prefix) = getpathenv s >>= \case
- Nothing -> return Nothing
- Just d -> Just <$> absPath (prefix </> d)
+ getpathenvprefix s (Just prefix) | not (null prefix) =
+ getpathenv s >>= \case
+ Nothing -> return Nothing
+ Just d
+ | d == "." -> return (Just d)
+ | otherwise -> Just <$> absPath (prefix </> d)
+ getpathenvprefix s _ = getpathenv s
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
diff --git a/Git/Index.hs b/Git/Index.hs
index 0898569..91f46f9 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -1,6 +1,6 @@
{- git index file stuff
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -47,12 +47,17 @@ override index _r = do
reset (Just v) = setEnv indexEnv v True
reset _ = unsetEnv var
+{- The normal index file. Does not check GIT_INDEX_FILE. -}
indexFile :: Repo -> FilePath
indexFile r = localGitDir r </> "index"
+{- The index file git will currently use, checking GIT_INDEX_FILE. -}
+currentIndexFile :: Repo -> IO FilePath
+currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv
+
{- Git locks the index by creating this file. -}
-indexFileLock :: Repo -> FilePath
-indexFileLock r = indexFile r ++ ".lock"
+indexFileLock :: FilePath -> FilePath
+indexFileLock f = f ++ ".lock"
{- When the pre-commit hook is run, and git commit has been run with
- a file or files specified to commit, rather than committing the staged
diff --git a/Git/Queue.hs b/Git/Queue.hs
index 232b4a7..3b855ae 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -1,6 +1,6 @@
{- git repository command queue
-
- - Copyright 2010,2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -12,6 +12,8 @@ module Git.Queue (
new,
addCommand,
addUpdateIndex,
+ addInternalAction,
+ InternalActionRunner(..),
size,
full,
flush,
@@ -38,14 +40,27 @@ data Action
, getParams :: [CommandParam]
, getFiles :: [CommandParam]
}
+ {- An internal action to run, on a list of files that can be added
+ - to as the queue grows. -}
+ | InternalAction
+ { getRunner :: InternalActionRunner
+ , getInternalFiles :: [(FilePath, IO Bool)]
+ }
+
+{- The String must be unique for each internal action. -}
+data InternalActionRunner = InternalActionRunner String (Repo -> [(FilePath, IO Bool)] -> IO ())
+
+instance Eq InternalActionRunner where
+ InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2
{- A key that can uniquely represent an action in a Map. -}
-data ActionKey = UpdateIndexActionKey | CommandActionKey String
+data ActionKey = UpdateIndexActionKey | CommandActionKey String | InternalActionKey String
deriving (Eq, Ord)
actionKey :: Action -> ActionKey
actionKey (UpdateIndexAction _) = UpdateIndexActionKey
actionKey CommandAction { getSubcommand = s } = CommandActionKey s
+actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s
{- A queue of actions to perform (in any order) on a git repository,
- with lists of files to perform them on. This allows coalescing
@@ -91,6 +106,19 @@ addCommand subcommand params files q repo =
different (CommandAction { getSubcommand = s }) = s /= subcommand
different _ = True
+{- Adds an internal action to the queue. -}
+addInternalAction :: InternalActionRunner -> [(FilePath, IO Bool)] -> Queue -> Repo -> IO Queue
+addInternalAction runner files q repo =
+ updateQueue action different (length files) q repo
+ where
+ action = InternalAction
+ { getRunner = runner
+ , getInternalFiles = files
+ }
+
+ different (InternalAction { getRunner = r }) = r /= runner
+ different _ = True
+
{- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
addUpdateIndex streamer q repo =
@@ -119,11 +147,16 @@ updateQueue !action different sizeincrease q repo
!newsize = size q' + sizeincrease
!newitems = M.insertWith combineNewOld (actionKey action) action (items q')
+{- The new value comes first. It probably has a smaller list of files than
+ - the old value. So, the list append of the new value first is more
+ - efficient. -}
combineNewOld :: Action -> Action -> Action
combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) =
CommandAction sc2 ps2 (fs1++fs2)
combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) =
UpdateIndexAction (s1++s2)
+combineNewOld (InternalAction _r1 fs1) (InternalAction r2 fs2) =
+ InternalAction r2 (fs1++fs2)
combineNewOld anew _aold = anew
{- Merges the contents of the second queue into the first.
@@ -172,3 +205,6 @@ runAction repo action@(CommandAction {}) = do
where
gitparams = gitCommandLine
(Param (getSubcommand action):getParams action) repo
+runAction repo action@(InternalAction {}) =
+ let InternalActionRunner _ runner = getRunner action
+ in runner repo (getInternalFiles action)
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index a6feaf5..f765c39 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -1,6 +1,6 @@
{- git-update-index library
-
- - Copyright 2011-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -21,6 +21,7 @@ module Git.UpdateIndex (
unstageFile,
stageSymlink,
stageDiffTreeItem,
+ refreshIndex,
) where
import Common
@@ -123,3 +124,23 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath
+
+{- Refreshes the index, by checking file stat information. -}
+refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
+refreshIndex repo feeder = do
+ (Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+ feeder $ \f -> do
+ hPutStr h f
+ hPutStr h "\0"
+ hFlush h
+ hClose h
+ checkSuccessProcess p
+ where
+ params =
+ [ Param "update-index"
+ , Param "-q"
+ , Param "--refresh"
+ , Param "-z"
+ , Param "--stdin"
+ ]
diff --git a/Logs.hs b/Logs.hs
index 7b6c7dd..0af14eb 100644
--- a/Logs.hs
+++ b/Logs.hs
@@ -1,6 +1,6 @@
{- git-annex log file names
-
- - Copyright 2013-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -16,6 +16,7 @@ data LogVariety
| NewUUIDBasedLog
| ChunkLog Key
| PresenceLog Key
+ | RemoteMetaDataLog
| OtherLog
deriving (Show)
@@ -26,6 +27,7 @@ getLogVariety f
| f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog
| isRemoteStateLog f = Just NewUUIDBasedLog
| isChunkLog f = ChunkLog <$> chunkLogFileKey f
+ | isRemoteMetaDataLog f = Just RemoteMetaDataLog
| isMetaDataLog f || f `elem` otherLogs = Just OtherLog
| otherwise = PresenceLog <$> firstJust (presenceLogs f)
@@ -185,3 +187,13 @@ metaDataLogExt = ".log.met"
isMetaDataLog :: FilePath -> Bool
isMetaDataLog path = metaDataLogExt `isSuffixOf` path
+
+{- The filename of the remote metadata log for a given key. -}
+remoteMetaDataLogFile :: GitConfig -> Key -> FilePath
+remoteMetaDataLogFile config key = branchHashDir config key </> keyFile key ++ remoteMetaDataLogExt
+
+remoteMetaDataLogExt :: String
+remoteMetaDataLogExt = ".log.rmet"
+
+isRemoteMetaDataLog :: FilePath -> Bool
+isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path
diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs
index 0393702..09e429c 100644
--- a/Logs/MetaData.hs
+++ b/Logs/MetaData.hs
@@ -1,7 +1,9 @@
-{- git-annex general metadata storage log
+{- git-annex general metadata storage log and per-remote metadata storage log.
-
- A line of the log will look like "timestamp field [+-]value [...]"
-
+ - (In the per-remote log, each field is prefixed with "uuid:")
+ -
- Note that unset values are preserved. Consider this case:
-
- We have:
@@ -18,17 +20,15 @@
- and so foo currently has no value.
-
-
- - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
module Logs.MetaData (
getCurrentMetaData,
+ getCurrentRemoteMetaData,
addMetaData,
- addMetaData',
+ addRemoteMetaData,
+ addMetaDataClocked,
currentMetaData,
copyMetaData,
) where
@@ -40,24 +40,12 @@ import Annex.VectorClock
import qualified Annex.Branch
import qualified Annex
import Logs
-import Logs.SingleValue
import Logs.TimeStamp
+import Logs.MetaData.Pure
import qualified Data.Set as S
import qualified Data.Map as M
-instance SingleValueSerializable MetaData where
- serialize = Types.MetaData.serialize
- deserialize = Types.MetaData.deserialize
-
-getMetaDataLog :: Key -> Annex (Log MetaData)
-getMetaDataLog key = do
- config <- Annex.getGitConfig
- readLog $ metaDataLogFile config key
-
-logToCurrentMetaData :: [LogEntry MetaData] -> MetaData
-logToCurrentMetaData = currentMetaData . combineMetaData . map value
-
{- Go through the log from oldest to newest, and combine it all
- into a single MetaData representing the current state.
-
@@ -65,8 +53,12 @@ logToCurrentMetaData = currentMetaData . combineMetaData . map value
- currently set, based on timestamps in the log.
-}
getCurrentMetaData :: Key -> Annex MetaData
-getCurrentMetaData k = do
- ls <- S.toAscList <$> getMetaDataLog k
+getCurrentMetaData = getCurrentMetaData' metaDataLogFile
+
+getCurrentMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> Annex MetaData
+getCurrentMetaData' getlogfile k = do
+ config <- Annex.getGitConfig
+ ls <- S.toAscList <$> readLog (getlogfile config k)
let loggedmeta = logToCurrentMetaData ls
return $ currentMetaData $ unionMetaData loggedmeta
(lastchanged ls loggedmeta)
@@ -92,86 +84,46 @@ getCurrentMetaData k = do
Unknown -> 0
showts = formatPOSIXTime "%F@%H-%M-%S"
+getCurrentRemoteMetaData :: UUID -> Key -> Annex RemoteMetaData
+getCurrentRemoteMetaData u k = extractRemoteMetaData u <$>
+ getCurrentMetaData' remoteMetaDataLogFile k
+
{- Adds in some metadata, which can override existing values, or unset
- them, but otherwise leaves any existing metadata as-is. -}
addMetaData :: Key -> MetaData -> Annex ()
-addMetaData k metadata = addMetaData' k metadata =<< liftIO currentVectorClock
+addMetaData = addMetaData' metaDataLogFile
+
+addMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> Annex ()
+addMetaData' getlogfile k metadata =
+ addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock
{- Reusing the same VectorClock when making changes to the metadata
- of multiple keys is a nice optimisation. The same metadata lines
- will tend to be generated across the different log files, and so
- git will be able to pack the data more efficiently. -}
-addMetaData' :: Key -> MetaData -> VectorClock -> Annex ()
-addMetaData' k d@(MetaData m) c
+addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex ()
+addMetaDataClocked = addMetaDataClocked' metaDataLogFile
+
+addMetaDataClocked' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> VectorClock -> Annex ()
+addMetaDataClocked' getlogfile k d@(MetaData m) c
| d == emptyMetaData = noop
| otherwise = do
config <- Annex.getGitConfig
- Annex.Branch.change (metaDataLogFile config k) $
+ Annex.Branch.change (getlogfile config k) $
showLog . simplifyLog
. S.insert (LogEntry c metadata)
. parseLog
where
metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m
-{- Simplify a log, removing historical values that are no longer
- - needed.
- -
- - This is not as simple as just making a single log line with the newest
- - state of all metadata. Consider this case:
- -
- - We have:
- -
- - 100 foo +x bar +y
- - 200 foo -x
- -
- - An unmerged remote has:
- -
- - 150 bar -y baz +w
- -
- - If what we have were simplified to "200 foo -x bar +y" then when the line
- - from the remote became available, it would be older than the simplified
- - line, and its change to bar would not take effect. That is wrong.
- -
- - Instead, simplify it to:
- -
- - 100 bar +y
- - 200 foo -x
- -
- - (Note that this ends up with the same number of lines as the
- - unsimplified version, so there's really no point in updating
- - the log to this version. Doing so would only add data to git,
- - with little benefit.)
- -
- - Now merging with the remote yields:
- -
- - 100 bar +y
- - 150 bar -y baz +w
- - 200 foo -x
- -
- - Simplifying again:
- -
- - 150 bar +z baz +w
- - 200 foo -x
- -}
-simplifyLog :: Log MetaData -> Log MetaData
-simplifyLog s = case sl of
- (newest:rest) ->
- let sl' = go [newest] (value newest) rest
- in if length sl' < length sl
- then S.fromList sl'
- else s
- _ -> s
- where
- sl = S.toDescList s
+addRemoteMetaData :: Key -> RemoteMetaData -> Annex ()
+addRemoteMetaData k m = do
+ addMetaData' remoteMetaDataLogFile k (fromRemoteMetaData m)
- go c _ [] = c
- go c newer (l:ls)
- | unique == emptyMetaData = go c newer ls
- | otherwise = go (l { value = unique } : c)
- (unionMetaData unique newer) ls
- where
- older = value l
- unique = older `differenceMetaData` newer
+getMetaDataLog :: Key -> Annex (Log MetaData)
+getMetaDataLog key = do
+ config <- Annex.getGitConfig
+ readLog $ metaDataLogFile config key
{- Copies the metadata from the old key to the new key.
-
@@ -195,3 +147,6 @@ copyMetaData oldkey newkey
Annex.Branch.change (metaDataLogFile config newkey) $
const $ showLog l
return True
+
+readLog :: FilePath -> Annex (Log MetaData)
+readLog = parseLog <$$> Annex.Branch.get
diff --git a/Logs/MetaData/Pure.hs b/Logs/MetaData/Pure.hs
new file mode 100644
index 0000000..6cfdf19
--- /dev/null
+++ b/Logs/MetaData/Pure.hs
@@ -0,0 +1,111 @@
+{- git-annex metadata log, pure operations
+ -
+ - Copyright 2014-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Logs.MetaData.Pure (
+ Log,
+ LogEntry(..),
+ parseLog,
+ showLog,
+ logToCurrentMetaData,
+ simplifyLog,
+ filterRemoteMetaData,
+ filterOutEmpty,
+) where
+
+import Types.MetaData
+import Logs.SingleValue.Pure
+import Types.UUID
+
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+
+instance SingleValueSerializable MetaData where
+ serialize = Types.MetaData.serialize
+ deserialize = Types.MetaData.deserialize
+
+logToCurrentMetaData :: [LogEntry MetaData] -> MetaData
+logToCurrentMetaData = currentMetaData . combineMetaData . map value
+
+{- Simplify a log, removing historical values that are no longer
+ - needed.
+ -
+ - This is not as simple as just making a single log line with the newest
+ - state of all metadata. Consider this case:
+ -
+ - We have:
+ -
+ - 100 foo +x bar +y
+ - 200 foo -x
+ -
+ - An unmerged remote has:
+ -
+ - 150 bar -y baz +w
+ -
+ - If what we have were simplified to "200 foo -x bar +y" then when the line
+ - from the remote became available, it would be older than the simplified
+ - line, and its change to bar would not take effect. That is wrong.
+ -
+ - Instead, simplify it to:
+ -
+ - 100 bar +y
+ - 200 foo -x
+ -
+ - (Note that this ends up with the same number of lines as the
+ - unsimplified version, so there's really no point in updating
+ - the log to this version. Doing so would only add data to git,
+ - with little benefit.)
+ -
+ - Now merging with the remote yields:
+ -
+ - 100 bar +y
+ - 150 bar -y baz +w
+ - 200 foo -x
+ -
+ - Simplifying again:
+ -
+ - 150 bar +z baz +w
+ - 200 foo -x
+ -}
+simplifyLog :: Log MetaData -> Log MetaData
+simplifyLog s = case sl of
+ (newest:rest) ->
+ let sl' = go [newest] (value newest) rest
+ in if length sl' < length sl
+ then S.fromList sl'
+ else s
+ _ -> s
+ where
+ sl = S.toDescList s
+
+ go c _ [] = c
+ go c newer (l:ls)
+ | unique == emptyMetaData = go c newer ls
+ | otherwise = go (l { value = unique } : c)
+ (unionMetaData unique newer) ls
+ where
+ older = value l
+ unique = older `differenceMetaData` newer
+
+{- Filters per-remote metadata on the basis of UUID.
+ -
+ - Note that the LogEntry's clock is left the same, so this should not be
+ - used except for in a transition.
+ -}
+filterRemoteMetaData :: (UUID -> Bool) -> Log MetaData -> Log MetaData
+filterRemoteMetaData p = S.map go
+ where
+ go l@(LogEntry { value = MetaData m }) =
+ l { value = MetaData $ M.filterWithKey fil m }
+ fil f _v = case splitRemoteMetaDataField f of
+ Just (u, _) -> p u
+ Nothing -> True
+
+{- Filters out log lines that are empty. -}
+filterOutEmpty :: Log MetaData -> Log MetaData
+filterOutEmpty = S.filter $ \l -> value l /= emptyMetaData
diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs
index d84abba..ff23485 100644
--- a/Logs/PreferredContent.hs
+++ b/Logs/PreferredContent.hs
@@ -58,7 +58,7 @@ checkMap getmap mu notpresent mkey afile d = do
m <- getmap
case M.lookup u m of
Nothing -> return d
- Just matcher -> checkMatcher matcher mkey afile notpresent d
+ Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d)
preferredContentMap :: Annex (FileMatcherMap Annex)
preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad) return
diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs
index 1a6181f..8e648a6 100644
--- a/Logs/SingleValue.hs
+++ b/Logs/SingleValue.hs
@@ -11,46 +11,20 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-module Logs.SingleValue where
+module Logs.SingleValue (
+ module Logs.SingleValue.Pure,
+ readLog,
+ getLog,
+ setLog,
+) where
import Annex.Common
import qualified Annex.Branch
-import Logs.Line
+import Logs.SingleValue.Pure
import Annex.VectorClock
import qualified Data.Set as S
-class SingleValueSerializable v where
- serialize :: v -> String
- deserialize :: String -> Maybe v
-
-data LogEntry v = LogEntry
- { changed :: VectorClock
- , value :: v
- } deriving (Eq, Ord)
-
-type Log v = S.Set (LogEntry v)
-
-showLog :: (SingleValueSerializable v) => Log v -> String
-showLog = unlines . map showline . S.toList
- where
- showline (LogEntry c v) = unwords [formatVectorClock c, serialize v]
-
-parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v
-parseLog = S.fromList . mapMaybe parse . splitLines
- where
- parse line = do
- let (sc, s) = splitword line
- c <- parseVectorClock sc
- v <- deserialize s
- Just (LogEntry c v)
- splitword = separate (== ' ')
-
-newestValue :: Log v -> Maybe v
-newestValue s
- | S.null s = Nothing
- | otherwise = Just (value $ S.findMax s)
-
readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v)
readLog = parseLog <$$> Annex.Branch.get
diff --git a/Logs/SingleValue/Pure.hs b/Logs/SingleValue/Pure.hs
new file mode 100644
index 0000000..de3ceb1
--- /dev/null
+++ b/Logs/SingleValue/Pure.hs
@@ -0,0 +1,45 @@
+{- git-annex single-value log, pure operations
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.SingleValue.Pure where
+
+import Annex.Common
+import Logs.Line
+import Annex.VectorClock
+
+import qualified Data.Set as S
+
+class SingleValueSerializable v where
+ serialize :: v -> String
+ deserialize :: String -> Maybe v
+
+data LogEntry v = LogEntry
+ { changed :: VectorClock
+ , value :: v
+ } deriving (Eq, Ord)
+
+type Log v = S.Set (LogEntry v)
+
+showLog :: (SingleValueSerializable v) => Log v -> String
+showLog = unlines . map showline . S.toList
+ where
+ showline (LogEntry c v) = unwords [formatVectorClock c, serialize v]
+
+parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v
+parseLog = S.fromList . mapMaybe parse . splitLines
+ where
+ parse line = do
+ let (sc, s) = splitword line
+ c <- parseVectorClock sc
+ v <- deserialize s
+ Just (LogEntry c v)
+ splitword = separate (== ' ')
+
+newestValue :: Log v -> Maybe v
+newestValue s
+ | S.null s = Nothing
+ | otherwise = Just (value $ S.findMax s)
diff --git a/Logs/Trust.hs b/Logs/Trust.hs
index 706140b..469e9b3 100644
--- a/Logs/Trust.hs
+++ b/Logs/Trust.hs
@@ -66,8 +66,12 @@ trustMapLoad :: Annex TrustMap
trustMapLoad = do
overrides <- Annex.getState Annex.forcetrust
l <- remoteList
- -- Exports are never trusted, since they are not key/value stores.
- exports <- filterM Types.Remote.isExportSupported l
+ -- Exports are not trusted, since they are not key/value stores.
+ -- This does not apply to appendonly exports, which are key/value
+ -- stores.
+ let untrustworthy r = pure (not (Types.Remote.appendonly r))
+ <&&> Types.Remote.isExportSupported r
+ exports <- filterM untrustworthy l
let exportoverrides = M.fromList $
map (\r -> (Types.Remote.uuid r, UnTrusted)) exports
logged <- trustMapRaw
diff --git a/P2P/IO.hs b/P2P/IO.hs
index 18971d9..59e7545 100644
--- a/P2P/IO.hs
+++ b/P2P/IO.hs
@@ -38,6 +38,7 @@ import Annex.ChangedRefs
import Control.Monad.Free
import Control.Monad.IO.Class
import System.Exit (ExitCode(..))
+import System.IO.Error
import Network.Socket
import Control.Concurrent
import Control.Concurrent.Async
@@ -159,9 +160,11 @@ runNet runst conn runner f = case f of
Left e -> return (Left (show e))
Right () -> runner next
ReceiveMessage next -> do
- v <- liftIO $ tryNonAsync $ getProtocolLine (connIhdl conn)
+ v <- liftIO $ tryIOError $ getProtocolLine (connIhdl conn)
case v of
- Left e -> return (Left (show e))
+ Left e
+ | isEOFError e -> runner (next (Just ProtocolEOF))
+ | otherwise -> return (Left (show e))
Right Nothing -> return (Left "protocol error")
Right (Just l) -> case parseMessage l of
Just m -> do
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 49a3d5b..29fe072 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -83,6 +83,7 @@ data Message
| DATA Len -- followed by bytes of data
| VALIDITY Validity
| ERROR String
+ | ProtocolEOF
deriving (Show)
instance Proto.Sendable Message where
@@ -108,6 +109,7 @@ instance Proto.Sendable Message where
formatMessage (VALIDITY Invalid) = ["INVALID"]
formatMessage (DATA len) = ["DATA", Proto.serialize len]
formatMessage (ERROR err) = ["ERROR", Proto.serialize err]
+ formatMessage (ProtocolEOF) = []
instance Proto.Receivable Message where
parseCommand "AUTH" = Proto.parse2 AUTH
@@ -367,6 +369,8 @@ serverLoop :: (Message -> Proto (ServerHandler a)) -> Proto (Maybe a)
serverLoop a = do
mcmd <- net receiveMessage
case mcmd of
+ -- Stop loop at EOF
+ Just ProtocolEOF -> return Nothing
-- When the client sends ERROR to the server, the server
-- gives up, since it's not clear what state the client
-- is in, and so not possible to recover.
diff --git a/Remote/Adb.hs b/Remote/Adb.hs
index 8e99f1f..13c1ebc 100644
--- a/Remote/Adb.hs
+++ b/Remote/Adb.hs
@@ -71,6 +71,7 @@ gen r u c gc = do
, remotetype = remote
, availability = LocallyAvailable
, readonly = False
+ , appendonly = False
, mkUnavailable = return Nothing
, getInfo = return
[ ("androidserial", fromAndroidSerial serial)
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index 841166e..d4ccf87 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -76,6 +76,7 @@ gen r _ c gc = do
, localpath = Nothing
, getRepo = return r
, readonly = True
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 024e06a..8bc0457 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -79,6 +79,7 @@ gen r u c gc = do
, remotetype = remote
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
, readonly = False
+ , appendonly = False
, mkUnavailable = return Nothing
, getInfo = return [("repo", buprepo)]
, claimUrl = Nothing
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 4a6af3e..da4db98 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -78,6 +78,7 @@ gen r u c gc = do
, remotetype = remote
, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
, readonly = False
+ , appendonly = False
, mkUnavailable = return Nothing
, getInfo = return [("repo", ddarRepoLocation ddarrepo)]
, claimUrl = Nothing
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 2fcb05d..c8e41ea 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -81,6 +81,7 @@ gen r u c gc = do
, gitconfig = gc
, localpath = Just dir
, readonly = False
+ , appendonly = False
, availability = LocallyAvailable
, remotetype = remote
, mkUnavailable = gen r u c $
diff --git a/Remote/External.hs b/Remote/External.hs
index 1427d61..292c716 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -127,6 +127,7 @@ gen r u c gc
, getRepo = return r
, gitconfig = gc
, readonly = False
+ , appendonly = False
, availability = avail
, remotetype = remote
{ exportSupported = cheapexportsupported }
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 20c4733..e1bc92b 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -127,6 +127,7 @@ gen' r u c gc = do
, getRepo = return r
, gitconfig = gc
, readonly = Git.repoIsHttp r
+ , appendonly = False
, availability = availabilityCalc r
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 979e8db..295c113 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -179,6 +179,7 @@ gen r u c gc
, getRepo = getRepoFromState st
, gitconfig = gc
, readonly = Git.repoIsHttp r
+ , appendonly = False
, availability = availabilityCalc r
, remotetype = remote
, mkUnavailable = unavailable r u c gc
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index ad5f2e2..c31edf2 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -73,6 +73,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, gitconfig = gc
, localpath = Nothing
, readonly = False
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index 8fe4dc5..0dabf5f 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -113,24 +113,20 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
{ storeKey = \_ _ _ -> do
warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"
return False
- -- Keys can be retrieved, but since an export
- -- is not a true key/value store, the content of
- -- the key has to be able to be strongly verified.
- , retrieveKeyFile = \k _af dest p -> unVerified $
- if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
- then do
- locs <- getexportlocs k
- case locs of
- [] -> do
- warning "unknown export location"
- return False
- (l:_) -> do
- ea <- exportActions r
- retrieveExport ea k l dest p
- else do
- warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
- return False
- , retrieveKeyFileCheap = \_ _ _ -> return False
+ -- Keys can be retrieved using retrieveExport,
+ -- but since that retrieves from a path in the
+ -- remote that another writer could have replaced
+ -- with content not of the requested key,
+ -- the content has to be strongly verified.
+ --
+ -- But, appendonly remotes have a key/value store,
+ -- so don't need to use retrieveExport.
+ , retrieveKeyFile = if appendonly r
+ then retrieveKeyFile r
+ else retrieveKeyFileFromExport getexportlocs
+ , retrieveKeyFileCheap = if appendonly r
+ then retrieveKeyFileCheap r
+ else \_ _ _ -> return False
-- Removing a key from an export would need to
-- change the tree in the export log to not include
-- the file. Otherwise, conflicts when removing
@@ -143,16 +139,40 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
-- Can't lock content on exports, since they're
-- not key/value stores, and someone else could
-- change what's exported to a file at any time.
- , lockContent = Nothing
- -- Check if any of the files a key was exported
- -- to are present. This doesn't guarantee the
- -- export contains the right content.
- , checkPresent = \k -> do
- ea <- exportActions r
- anyM (checkPresentExport ea k)
- =<< getexportlocs k
+ --
+ -- (except for appendonly remotes)
+ , lockContent = if appendonly r
+ then lockContent r
+ else Nothing
+ -- Check if any of the files a key was exported to
+ -- are present. This doesn't guarantee the export
+ -- contains the right content, which is why export
+ -- remotes are untrusted.
+ --
+ -- (but appendonly remotes work the same as any
+ -- non-export remote)
+ , checkPresent = if appendonly r
+ then checkPresent r
+ else \k -> do
+ ea <- exportActions r
+ anyM (checkPresentExport ea k)
+ =<< getexportlocs k
, mkUnavailable = return Nothing
, getInfo = do
is <- getInfo r
return (is++[("export", "yes")])
}
+ retrieveKeyFileFromExport getexportlocs k _af dest p = unVerified $
+ if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
+ then do
+ locs <- getexportlocs k
+ case locs of
+ [] -> do
+ warning "unknown export location"
+ return False
+ (l:_) -> do
+ ea <- exportActions r
+ retrieveExport ea k l dest p
+ else do
+ warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
+ return False
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index a6e5339..fb81a7e 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -65,6 +65,7 @@ gen r u c gc = do
, getRepo = return r
, gitconfig = gc
, readonly = False
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = gen r u c $
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index c47a9e6..3b3b0bf 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -67,6 +67,7 @@ chainGen addr r u c gc = do
, getRepo = return r
, gitconfig = gc
, readonly = False
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 8f4e8ac..216fd0f 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -95,6 +95,7 @@ gen r u c gc = do
then Just $ rsyncUrl o
else Nothing
, readonly = False
+ , appendonly = False
, availability = if islocal then LocallyAvailable else GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 6de43a3..e1cc1b8 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -18,8 +18,9 @@ import qualified Aws.S3 as S3
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString as S
+import qualified Data.ByteString as BS
import qualified Data.Map as M
+import qualified Data.Set as S
import Data.Char
import Network.Socket (HostName)
import Network.HTTP.Conduit (Manager)
@@ -45,6 +46,8 @@ import qualified Remote.Helper.AWS as AWS
import Creds
import Annex.UUID
import Logs.Web
+import Logs.MetaData
+import Types.MetaData
import Utility.Metered
import qualified Annex.Url as Url
import Utility.DataUnits
@@ -52,6 +55,7 @@ import Utility.FileSystemEncoding
import Annex.Content
import Annex.Url (withUrlOptions)
import Utility.Url (checkBoth, UrlOptions(..))
+import Utility.Env
type BucketName = String
type BucketObject = String
@@ -73,9 +77,9 @@ gen r u c gc = do
where
new cst info = Just $ specialRemote c
(prepareS3Handle this $ store this info)
- (prepareS3HandleMaybe this $ retrieve this info)
+ (prepareS3HandleMaybe this $ retrieve this c info)
(prepareS3Handle this $ remove info)
- (prepareS3HandleMaybe this $ checkKey this info)
+ (prepareS3HandleMaybe this $ checkKey this c info)
this
where
this = Remote
@@ -102,7 +106,7 @@ gen r u c gc = do
, removeExportDirectory = Nothing
, renameExport = renameExportS3 u info mh
}
- , whereisKey = Just (getWebUrls info c)
+ , whereisKey = Just (getPublicWebUrls u info c)
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
@@ -110,6 +114,7 @@ gen r u c gc = do
, gitconfig = gc
, localpath = Nothing
, readonly = False
+ , appendonly = versioning info
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
@@ -186,13 +191,13 @@ prepareS3HandleMaybe r = resourcePrepare $ const $
store :: Remote -> S3Info -> S3Handle -> Storer
store _r info h = fileStorer $ \k f p -> do
- storeHelper info h f (T.pack $ bucketObject info k) p
+ void $ storeHelper info h f (T.pack $ bucketObject info k) p
-- Store public URL to item in Internet Archive.
when (isIA info && not (isChunkKey k)) $
setUrlPresent webUUID k (iaPublicUrl info (bucketObject info k))
return True
-storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex ()
+storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID)
storeHelper info h f object p = case partSize info of
Just partsz | partsz > 0 -> do
fsz <- liftIO $ getFileSize f
@@ -203,9 +208,10 @@ storeHelper info h f object p = case partSize info of
where
singlepartupload = do
rbody <- liftIO $ httpBodyStorer f p
- void $ sendS3Handle h $ putObject info object rbody
+ r <- sendS3Handle h $ putObject info object rbody
+ return (mkS3VersionID object (S3.porVersionId r))
multipartupload fsz partsz = do
-#if MIN_VERSION_aws(0,10,6)
+#if MIN_VERSION_aws(0,16,0)
let startreq = (S3.postInitiateMultipartUpload (bucket info) object)
{ S3.imuStorageClass = Just (storageClass info)
, S3.imuMetadata = metaHeaders info
@@ -240,8 +246,9 @@ storeHelper info h f object p = case partSize info of
sendparts (offsetMeterUpdate meter (toBytesProcessed sz)) (etag:etags) (partnum + 1)
sendparts p [] 1
- void $ sendS3Handle h $ S3.postCompleteMultipartUpload
+ r <- sendS3Handle h $ S3.postCompleteMultipartUpload
(bucket info) object uploadid (zip [1..] etags)
+ return (mkS3VersionID object (S3.cmurVersionId r))
#else
warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library."
singlepartupload
@@ -250,20 +257,24 @@ storeHelper info h f object p = case partSize info of
{- Implemented as a fileRetriever, that uses conduit to stream the chunks
- out to the file. Would be better to implement a byteRetriever, but
- that is difficult. -}
-retrieve :: Remote -> S3Info -> Maybe S3Handle -> Retriever
-retrieve _ info (Just h) = fileRetriever $ \f k p ->
- retrieveHelper info h (T.pack $ bucketObject info k) f p
-retrieve r info Nothing = case getpublicurl info of
- Nothing -> \_ _ _ -> do
- needS3Creds (uuid r)
- return False
- Just geturl -> fileRetriever $ \f k p ->
- unlessM (downloadUrl k p [geturl $ bucketObject info k] f) $
+retrieve :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> Retriever
+retrieve r _ info (Just h) = fileRetriever $ \f k p -> do
+ loc <- eitherS3VersionID info (uuid r) k (T.pack $ bucketObject info k)
+ retrieveHelper info h loc f p
+retrieve r c info Nothing = fileRetriever $ \f k p ->
+ getPublicWebUrls (uuid r) info c k >>= \case
+ [] -> do
+ needS3Creds (uuid r)
+ giveup "No S3 credentials configured"
+ us -> unlessM (downloadUrl k p us f) $
giveup "failed to download content"
-retrieveHelper :: S3Info -> S3Handle -> S3.Object -> FilePath -> MeterUpdate -> Annex ()
-retrieveHelper info h object f p = liftIO $ runResourceT $ do
- let req = S3.getObject (bucket info) object
+retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex ()
+retrieveHelper info h loc f p = liftIO $ runResourceT $ do
+ let req = case loc of
+ Left o -> S3.getObject (bucket info) o
+ Right (S3VersionID o vid) -> (S3.getObject (bucket info) o)
+ { S3.goVersionId = Just (T.pack vid) }
S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req
Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp
@@ -279,21 +290,24 @@ remove info h k = do
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return $ either (const False) (const True) res
-checkKey :: Remote -> S3Info -> Maybe S3Handle -> CheckPresent
-checkKey r info Nothing k = case getpublicurl info of
- Nothing -> do
- needS3Creds (uuid r)
- giveup "No S3 credentials configured"
- Just geturl -> do
- showChecking r
- withUrlOptions $ liftIO .
- checkBoth (geturl $ bucketObject info k) (keySize k)
-checkKey r info (Just h) k = do
+checkKey :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> CheckPresent
+checkKey r _ info (Just h) k = do
showChecking r
- checkKeyHelper info h (T.pack $ bucketObject info k)
-
-checkKeyHelper :: S3Info -> S3Handle -> S3.Object -> Annex Bool
-checkKeyHelper info h object = do
+ loc <- eitherS3VersionID info (uuid r) k (T.pack $ bucketObject info k)
+ checkKeyHelper info h loc
+checkKey r c info Nothing k =
+ getPublicWebUrls (uuid r) info c k >>= \case
+ [] -> do
+ needS3Creds (uuid r)
+ giveup "No S3 credentials configured"
+ us -> do
+ showChecking r
+ let check u = withUrlOptions $
+ liftIO . checkBoth u (keySize k)
+ anyM check us
+
+checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool
+checkKeyHelper info h loc = do
#if MIN_VERSION_aws(0,10,0)
rsp <- go
return (isJust $ S3.horMetadata rsp)
@@ -303,7 +317,11 @@ checkKeyHelper info h object = do
return True
#endif
where
- go = sendS3Handle h $ S3.headObject (bucket info) object
+ go = sendS3Handle h req
+ req = case loc of
+ Left o -> S3.headObject (bucket info) o
+ Right (S3VersionID o vid) -> (S3.headObject (bucket info) o)
+ { S3.hoVersionId = Just (T.pack vid) }
#if ! MIN_VERSION_aws(0,10,0)
{- Catch exception headObject returns when an object is not present
@@ -319,11 +337,13 @@ checkKeyHelper info h object = do
#endif
storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportS3 _u info (Just h) f _k loc p =
+storeExportS3 u info (Just h) f k loc p =
catchNonAsync go (\e -> warning (show e) >> return False)
where
go = do
- storeHelper info h f (T.pack $ bucketExportLocation info loc) p
+ let o = T.pack $ bucketExportLocation info loc
+ storeHelper info h f o p
+ >>= setS3VersionID info u k
return True
storeExportS3 u _ Nothing _ _ _ _ = do
needS3Creds u
@@ -335,9 +355,9 @@ retrieveExportS3 u info mh _k loc f p =
where
go = case mh of
Just h -> do
- retrieveHelper info h (T.pack exporturl) f p
+ retrieveHelper info h (Left (T.pack exporturl)) f p
return True
- Nothing -> case getpublicurl info of
+ Nothing -> case getPublicUrlMaker info of
Nothing -> do
needS3Creds u
return False
@@ -359,8 +379,8 @@ removeExportS3 u _ Nothing _ _ = do
checkPresentExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool
checkPresentExportS3 _u info (Just h) _k loc =
- checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
-checkPresentExportS3 u info Nothing k loc = case getpublicurl info of
+ checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
+checkPresentExportS3 u info Nothing k loc = case getPublicUrlMaker info of
Nothing -> do
needS3Creds u
giveup "No S3 credentials configured"
@@ -536,14 +556,14 @@ s3Configuration c = cfg
proto
| port == 443 = AWS.HTTPS
| otherwise = AWS.HTTP
- host = fromJust $ M.lookup "host" c
+ h = fromJust $ M.lookup "host" c
datacenter = fromJust $ M.lookup "datacenter" c
-- When the default S3 host is configured, connect directly to
-- the S3 endpoint for the configured datacenter.
-- When another host is configured, it's used as-is.
endpoint
- | host == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter
- | otherwise = T.encodeUtf8 $ T.pack host
+ | h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter
+ | otherwise = T.encodeUtf8 $ T.pack h
port = let s = fromJust $ M.lookup "port" c in
case reads s of
[(p, _)] -> p
@@ -558,8 +578,10 @@ data S3Info = S3Info
, metaHeaders :: [(T.Text, T.Text)]
, partSize :: Maybe Integer
, isIA :: Bool
+ , versioning :: Bool
, public :: Bool
- , getpublicurl :: Maybe (BucketObject -> URLString)
+ , publicurl :: Maybe URLString
+ , host :: Maybe String
}
extractS3Info :: RemoteConfig -> Annex S3Info
@@ -568,7 +590,7 @@ extractS3Info c = do
(giveup "S3 bucket not configured")
(return . T.pack)
(getBucketName c)
- let info = S3Info
+ return $ S3Info
{ bucket = b
, storageClass = getStorageClass c
, bucketObject = getBucketObject c
@@ -576,20 +598,15 @@ extractS3Info c = do
, metaHeaders = getMetaHeaders c
, partSize = getPartSize c
, isIA = configIA c
- , public = case M.lookup "public" c of
- Just "yes" -> True
- _ -> False
- , getpublicurl = case M.lookup "publicurl" c of
- Just u -> Just $ \p -> genericPublicUrl p u
- Nothing -> case M.lookup "host" c of
- Just h
- | h == AWS.s3DefaultHost ->
- Just (awsPublicUrl info)
- | isIAHost h ->
- Just (iaPublicUrl info)
- _ -> Nothing
+ , versioning = boolcfg "versioning"
+ , public = boolcfg "public"
+ , publicurl = M.lookup "publicurl" c
+ , host = M.lookup "host" c
}
- return info
+ where
+ boolcfg k = case M.lookup k c of
+ Just "yes" -> True
+ _ -> False
putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject
putObject info file rbody = (S3.putObject (bucket info) file rbody)
@@ -665,22 +682,24 @@ iaItemUrl :: BucketName -> URLString
iaItemUrl b = "http://archive.org/details/" ++ b
iaPublicUrl :: S3Info -> BucketObject -> URLString
-iaPublicUrl info p = genericPublicUrl p $
+iaPublicUrl info = genericPublicUrl $
"http://archive.org/download/" ++ T.unpack (bucket info) ++ "/"
awsPublicUrl :: S3Info -> BucketObject -> URLString
-awsPublicUrl info p = genericPublicUrl p $
+awsPublicUrl info = genericPublicUrl $
"https://" ++ T.unpack (bucket info) ++ ".s3.amazonaws.com/"
-genericPublicUrl :: BucketObject -> URLString -> URLString
-genericPublicUrl p baseurl = baseurl ++ p
+genericPublicUrl :: URLString -> BucketObject -> URLString
+genericPublicUrl baseurl p = baseurl ++ p
genCredentials :: CredPair -> IO AWS.Credentials
genCredentials (keyid, secret) = AWS.Credentials
- <$> pure (T.encodeUtf8 (T.pack keyid))
- <*> pure (T.encodeUtf8 (T.pack secret))
+ <$> pure (tobs keyid)
+ <*> pure (tobs secret)
<*> newIORef []
- <*> pure Nothing
+ <*> (fmap tobs <$> getEnv "AWS_SESSION_TOKEN")
+ where
+ tobs = T.encodeUtf8 . T.pack
mkLocationConstraint :: AWS.Region -> S3.LocationConstraint
mkLocationConstraint "US" = S3.locationUsClassic
@@ -698,7 +717,7 @@ debugMapper level t = forward "S3" (T.unpack t)
s3Info :: RemoteConfig -> S3Info -> [(String, String)]
s3Info c info = catMaybes
[ Just ("bucket", fromMaybe "unknown" (getBucketName c))
- , Just ("endpoint", w82s (S.unpack (S3.s3Endpoint s3c)))
+ , Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c)))
, Just ("port", show (S3.s3Port s3c))
, Just ("storage class", showstorageclass (getStorageClass c))
, if configIA c
@@ -706,6 +725,7 @@ s3Info c info = catMaybes
else Nothing
, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
, Just ("public", if public info then "yes" else "no")
+ , Just ("versioning", if versioning info then "yes" else "no")
]
where
s3c = s3Configuration c
@@ -714,10 +734,102 @@ s3Info c info = catMaybes
#endif
showstorageclass sc = show sc
-getWebUrls :: S3Info -> RemoteConfig -> Key -> Annex [URLString]
-getWebUrls info c k
- | exportTree c = return []
- | otherwise = case (public info, getpublicurl info) of
- (True, Just geturl) -> return [geturl $ bucketObject info k]
- _ -> return []
+getPublicWebUrls :: UUID -> S3Info -> RemoteConfig -> Key -> Annex [URLString]
+getPublicWebUrls u info c k
+ | not (public info) = return []
+ | exportTree c = if versioning info
+ then case publicurl info of
+ Just url -> getS3VersionIDPublicUrls (const $ genericPublicUrl url) info u k
+ Nothing -> case host info of
+ Just h | h == AWS.s3DefaultHost ->
+ getS3VersionIDPublicUrls awsPublicUrl info u k
+ _ -> return []
+ else return []
+ | otherwise = case getPublicUrlMaker info of
+ Just geturl -> return [geturl $ bucketObject info k]
+ Nothing -> return []
+
+getPublicUrlMaker :: S3Info -> Maybe (BucketObject -> URLString)
+getPublicUrlMaker info = case publicurl info of
+ Just url -> Just (genericPublicUrl url)
+ Nothing -> case host info of
+ Just h
+ | h == AWS.s3DefaultHost ->
+ Just (awsPublicUrl info)
+ | isIAHost h ->
+ Just (iaPublicUrl info)
+ _ -> Nothing
+
+
+data S3VersionID = S3VersionID S3.Object String
+ deriving (Show)
+
+-- smart constructor
+mkS3VersionID :: S3.Object -> Maybe T.Text -> Maybe S3VersionID
+mkS3VersionID o = mkS3VersionID' o . fmap T.unpack
+
+mkS3VersionID' :: S3.Object -> Maybe String -> Maybe S3VersionID
+mkS3VersionID' o (Just s)
+ | null s = Nothing
+ -- AWS documentation says a version ID is at most 1024 bytes long.
+ -- Since they are stored in the git-annex branch, prevent them from
+ -- being very much larger than that.
+ | length s < 2048 = Just (S3VersionID o s)
+ | otherwise = Nothing
+mkS3VersionID' _ Nothing = Nothing
+
+-- Format for storage in per-remote metadata.
+--
+-- A S3 version ID is "url ready" so does not contain '#' and so we'll use
+-- that to separate it from the object id. (Could use a space, but spaces
+-- in metadata values lead to an inefficient encoding.)
+formatS3VersionID :: S3VersionID -> String
+formatS3VersionID (S3VersionID o v) = v ++ '#' : T.unpack o
+
+-- Parse from value stored in per-remote metadata.
+parseS3VersionID :: String -> Maybe S3VersionID
+parseS3VersionID s =
+ let (v, o) = separate (== '#') s
+ in mkS3VersionID' (T.pack o) (Just v)
+
+setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex ()
+setS3VersionID info u k vid
+ | versioning info = maybe noop (setS3VersionID' u k) vid
+ | otherwise = noop
+
+setS3VersionID' :: UUID -> Key -> S3VersionID -> Annex ()
+setS3VersionID' u k vid = addRemoteMetaData k $
+ RemoteMetaData u (updateMetaData s3VersionField v emptyMetaData)
+ where
+ v = mkMetaValue (CurrentlySet True) (formatS3VersionID vid)
+
+getS3VersionID :: UUID -> Key -> Annex [S3VersionID]
+getS3VersionID u k = do
+ (RemoteMetaData _ m) <- getCurrentRemoteMetaData u k
+ return $ mapMaybe parseS3VersionID $ map unwrap $ S.toList $
+ metaDataValues s3VersionField m
+ where
+ unwrap (MetaValue _ v) = v
+
+s3VersionField :: MetaField
+s3VersionField = mkMetaFieldUnchecked "V"
+
+eitherS3VersionID :: S3Info -> UUID -> Key -> S3.Object -> Annex (Either S3.Object S3VersionID)
+eitherS3VersionID info u k fallback
+ | versioning info = getS3VersionID u k >>= return . \case
+ [] -> Left fallback
+ -- It's possible for a key to be stored multiple timees in
+ -- a bucket with different version IDs; only use one of them.
+ (v:_) -> Right v
+ | otherwise = return (Left fallback)
+
+s3VersionIDPublicUrl :: (S3Info -> BucketObject -> URLString) -> S3Info -> S3VersionID -> URLString
+s3VersionIDPublicUrl mk info (S3VersionID obj vid) = mk info $ concat
+ [ T.unpack obj
+ , "?versionId="
+ , vid -- version ID is "url ready" so no escaping needed
+ ]
+getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString]
+getS3VersionIDPublicUrls mk info u k =
+ map (s3VersionIDPublicUrl mk info) <$> getS3VersionID u k
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 5615c48..527121d 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -88,6 +88,7 @@ gen r u c gc = do
, gitconfig = gc
, localpath = Nothing
, readonly = False
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/Web.hs b/Remote/Web.hs
index da849bc..047bb6c 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -66,6 +66,7 @@ gen r _ c gc = do
, localpath = Nothing
, getRepo = return r
, readonly = True
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index d8fc8be..81ffc72 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -96,6 +96,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, gitconfig = gc
, localpath = Nothing
, readonly = False
+ , appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
diff --git a/Types/MetaData.hs b/Types/MetaData.hs
index e0be811..95b7dbb 100644
--- a/Types/MetaData.hs
+++ b/Types/MetaData.hs
@@ -1,6 +1,6 @@
{- git-annex general metadata
-
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -36,6 +36,10 @@ module Types.MetaData (
metaDataValues,
ModMeta(..),
modMeta,
+ RemoteMetaData(..),
+ extractRemoteMetaData,
+ splitRemoteMetaDataField,
+ fromRemoteMetaData,
prop_metadata_sane,
prop_metadata_serialize
) where
@@ -44,6 +48,7 @@ import Common
import Utility.Base64
import Utility.QuickCheck
import Utility.Aeson
+import Types.UUID
import qualified Data.Text as T
import qualified Data.Set as S
@@ -282,6 +287,37 @@ modMeta m (MaybeSetMeta f v)
| otherwise = emptyMetaData
modMeta m (ComposeModMeta a b) = unionMetaData (modMeta m a) (modMeta m b)
+data RemoteMetaData = RemoteMetaData UUID MetaData
+ deriving (Show, Eq, Ord)
+
+{- Extracts only the fields prefixed with "uuid:", which belong to that
+ - remote. -}
+extractRemoteMetaData :: UUID -> MetaData -> RemoteMetaData
+extractRemoteMetaData u (MetaData m) = RemoteMetaData u $ MetaData $
+ M.mapKeys removeprefix $ M.filterWithKey belongsremote m
+ where
+ belongsremote (MetaField f) _v = prefix `isPrefixOf` CI.original f
+ removeprefix (MetaField f) = MetaField $
+ CI.mk $ drop prefixlen $ CI.original f
+ prefix = remoteMetaDataPrefix u
+ prefixlen = length prefix
+
+splitRemoteMetaDataField :: MetaField -> Maybe (UUID, MetaField)
+splitRemoteMetaDataField (MetaField f) = do
+ let (su, sf) = separate (== ':') (CI.original f)
+ f' <- toMetaField sf
+ return $ (toUUID su, f')
+
+remoteMetaDataPrefix :: UUID -> String
+remoteMetaDataPrefix u = fromUUID u ++ ":"
+
+fromRemoteMetaData :: RemoteMetaData -> MetaData
+fromRemoteMetaData (RemoteMetaData u (MetaData m)) = MetaData $
+ M.mapKeys addprefix m
+ where
+ addprefix (MetaField f) = MetaField $ CI.mk $ (prefix ++) $ CI.original f
+ prefix = remoteMetaDataPrefix u
+
{- Avoid putting too many fields in the map; extremely large maps make
- the seriaization test slow due to the sheer amount of data.
- It's unlikely that more than 100 fields of metadata will be used. -}
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 9922b65..3f49c81 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -55,7 +55,7 @@ data RemoteTypeA a = RemoteType
-- enumerates remotes of this type
-- The Bool is True if automatic initialization of remotes is desired
, enumerate :: Bool -> a [Git.Repo]
- -- generates a remote of this type from the current git config
+ -- generates a remote of this type
, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a))
-- initializes or enables a remote
, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
@@ -122,6 +122,11 @@ data RemoteA a = Remote
, localpath :: Maybe FilePath
-- a Remote can be known to be readonly
, readonly :: Bool
+ -- a Remote can allow writes but not have a way to delete content
+ -- from it. Note that an export remote that supports removeExport
+ -- to remove a file from the exported tree, but still retains the
+ -- content in accessible form should set this to True.
+ , appendonly :: Bool
-- a Remote can be globally available. (Ie, "in the cloud".)
, availability :: Availability
-- the type of the remote
diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs
index a05f2e0..7ce8bbe 100644
--- a/Upgrade/V5.hs
+++ b/Upgrade/V5.hs
@@ -10,6 +10,7 @@ module Upgrade.V5 where
import Annex.Common
import qualified Annex
import Config
+import Config.Smudge
import Annex.InodeSentinal
import Annex.Link
import Annex.Direct
diff --git a/Utility/DirWatcher/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs
index cd26f47..a0077d7 100644
--- a/Utility/DirWatcher/Kqueue.hs
+++ b/Utility/DirWatcher/Kqueue.hs
@@ -109,7 +109,7 @@ scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
Nothing -> walk c rest
Just info -> do
mfd <- catchMaybeIO $
- openFd dir ReadOnly Nothing defaultFileFlags
+ Files.openFd dir Files.ReadOnly Nothing Files.defaultFileFlags
case mfd of
Nothing -> walk c rest
Just fd -> do
@@ -129,7 +129,7 @@ addSubDirs dirmap prune dirs = do
{- Removes a subdirectory (and all its children) from a directory map. -}
removeSubDir :: DirMap -> FilePath -> IO DirMap
removeSubDir dirmap dir = do
- mapM_ closeFd $ M.keys toremove
+ mapM_ Files.closeFd $ M.keys toremove
return rest
where
(toremove, rest) = M.partition (dirContains dir . dirName) dirmap
@@ -167,7 +167,7 @@ updateKqueue (Kqueue h _ dirmap _) =
{- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap,
- so it can be reused. -}
stopKqueue :: Kqueue -> IO ()
-stopKqueue = closeFd . kqueueFd
+stopKqueue = Files.closeFd . kqueueFd
{- Waits for a change on a Kqueue.
- May update the Kqueue.
diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs
deleted file mode 100644
index 7b08820..0000000
--- a/Utility/ExternalSHA.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-{- Calculating a SHA checksum with an external command.
- -
- - This is typically a bit faster than using Haskell libraries,
- - by around 1% to 10%. Worth it for really big files.
- -
- - Copyright 2011-2013 Joey Hess <id@joeyh.name>
- -
- - License: BSD-2-clause
- -}
-
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Utility.ExternalSHA (externalSHA) where
-
-import Utility.SafeCommand
-import Utility.Process
-import Utility.Misc
-import Utility.Exception
-
-import Data.List
-import Data.Char
-import System.IO
-
-externalSHA :: String -> Int -> FilePath -> IO (Either String String)
-externalSHA command shasize file = do
- v <- tryNonAsync $ readsha $ toCommand [File file]
- return $ case v of
- Right s -> sanitycheck =<< parse (lines s)
- Left _ -> Left (command ++ " failed")
- where
- readsha args = withHandle StdoutHandle createProcessSuccess p $ \h -> do
- output <- hGetContentsStrict h
- hClose h
- return output
- where
- p = (proc command args) { std_out = CreatePipe }
-
- {- The first word of the output is taken to be the sha. -}
- parse [] = bad
- parse (l:_)
- | null sha = bad
- -- sha is prefixed with \ when filename contains certian chars
- | "\\" `isPrefixOf` sha = Right $ drop 1 sha
- | otherwise = Right sha
- where
- sha = fst $ separate (== ' ') l
- bad = Left $ command ++ " parse error"
-
- {- Check that we've correctly parsing the output of the command,
- - by making sure the sha we read is of the expected length
- - and contains only the right characters. -}
- sanitycheck sha
- | length sha /= expectedSHALength shasize =
- Left $ "Failed to parse the output of " ++ command
- | any (`notElem` "0123456789abcdef") sha' =
- Left $ "Unexpected character in output of " ++ command ++ "\"" ++ sha ++ "\""
- | otherwise = Right sha'
- where
- sha' = map toLower sha
-
-expectedSHALength :: Int -> Int
-expectedSHALength 1 = 40
-expectedSHALength 256 = 64
-expectedSHALength 512 = 128
-expectedSHALength 224 = 56
-expectedSHALength 384 = 96
-expectedSHALength _ = 0
diff --git a/Utility/Mounts.hs b/Utility/Mounts.hs
index 504d918..47b24b1 100644
--- a/Utility/Mounts.hs
+++ b/Utility/Mounts.hs
@@ -18,7 +18,8 @@ import Utility.Exception
getMounts :: IO [Mntent]
#ifndef __ANDROID__
getMounts = System.MountPoints.getMounts
- -- That will crash when running on Android, so fall back to this.
+ -- That will crash when the linux build is running on Android,
+ -- so fall back to this.
`catchNonAsync` const System.MountPoints.getProcMounts
#else
getMounts = System.MountPoints.getProcMounts
diff --git a/Utility/SRV.hs b/Utility/SRV.hs
deleted file mode 100644
index df81f49..0000000
--- a/Utility/SRV.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{- SRV record lookup
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - License: BSD-2-clause
- -}
-
-module Utility.SRV (
- mkSRVTcp,
- mkSRV,
- lookupSRV,
- HostPort,
-) where
-
-import Data.Function
-import Data.List
-import Network
-import qualified Network.DNS.Lookup as DNS
-import Network.DNS.Resolver
-import qualified Data.ByteString.UTF8 as B8
-
-newtype SRV = SRV String
- deriving (Show, Eq)
-
-type HostPort = (HostName, PortID)
-
-type PriorityWeight = (Int, Int) -- sort by priority first, then weight
-
-mkSRV :: String -> String -> HostName -> SRV
-mkSRV transport protocol host = SRV $ concat
- ["_", protocol, "._", transport, ".", host]
-
-mkSRVTcp :: String -> HostName -> SRV
-mkSRVTcp = mkSRV "tcp"
-
-{- Returns an ordered list, with highest priority hosts first.
- -
- - On error, returns an empty list. -}
-lookupSRV :: SRV -> IO [HostPort]
-lookupSRV (SRV srv) = do
- seed <- makeResolvSeed defaultResolvConf
- r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
- return $ either (const []) use r
- where
- use = orderHosts . map tohosts
- tohosts (priority, weight, port, hostname) =
- ( (fromIntegral priority, fromIntegral weight)
- , (B8.toString hostname, PortNumber $ fromIntegral port)
- )
-
-orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]
-orderHosts = map snd . sortBy (compare `on` fst)
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index eb34d3d..f820e69 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -27,19 +27,21 @@ data CommandParam
-- | Used to pass a list of CommandParams to a function that runs
-- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
-toCommand = map unwrap
+toCommand = map toCommand'
+
+toCommand' :: CommandParam -> String
+toCommand' (Param s) = s
+-- Files that start with a non-alphanumeric that is not a path
+-- separator are modified to avoid the command interpreting them as
+-- options or other special constructs.
+toCommand' (File s@(h:_))
+ | isAlphaNum h || h `elem` pathseps = s
+ | otherwise = "./" ++ s
where
- unwrap (Param s) = s
- -- Files that start with a non-alphanumeric that is not a path
- -- separator are modified to avoid the command interpreting them as
- -- options or other special constructs.
- unwrap (File s@(h:_))
- | isAlphaNum h || h `elem` pathseps = s
- | otherwise = "./" ++ s
- unwrap (File s) = s
-- '/' is explicitly included because it's an alternative
-- path separator on Windows.
pathseps = pathSeparator:"./"
+toCommand' (File s) = s
-- | Run a system command, and returns True or False if it succeeded or failed.
--
diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs
index 7ab3c8c..f941cfc 100644
--- a/Utility/SimpleProtocol.hs
+++ b/Utility/SimpleProtocol.hs
@@ -113,6 +113,8 @@ dupIoHandles = do
- This implementation is not super efficient, but as long as the Handle
- supports buffering, it avoids reading a character at a time at the
- syscall level.
+ -
+ - Throws isEOFError when no more input is available.
-}
getProtocolLine :: Handle -> IO (Maybe String)
getProtocolLine h = go (32768 :: Int) []
diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs
index ddf6ddb..36f69a8 100644
--- a/Utility/Tmp/Dir.hs
+++ b/Utility/Tmp/Dir.hs
@@ -1,4 +1,4 @@
-{- Temporary directorie
+{- Temporary directories
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
diff --git a/doc/git-annex-add.mdwn b/doc/git-annex-add.mdwn
index ff7bc40..f24ec76 100644
--- a/doc/git-annex-add.mdwn
+++ b/doc/git-annex-add.mdwn
@@ -77,8 +77,9 @@ annexed content, and other symlinks.
the file is added, and repeat.
Note that if a file is skipped (due to not existing, being gitignored,
- already being in git etc), an empty line will be output instead of the
- normal output produced when adding a file.
+ already being in git, or doesn't meet the matching options),
+ an empty line will be output instead of the normal output produced
+ when adding a file.
# SEE ALSO
diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn
index fedeaa0..9a5b48b 100644
--- a/doc/git-annex-copy.mdwn
+++ b/doc/git-annex-copy.mdwn
@@ -80,8 +80,9 @@ Copies the content of files from or to another remote.
are read from stdin.
As each specified file is processed, the usual progress output is
- displayed. If a file's content does not need to be copied or it
- is not an annexed file, a blank line is output in response instead.
+ displayed. If a file's content does not need to be copied, or it does not
+ match specified matching options, or it is not an annexed file,
+ a blank line is output in response instead.
Since the usual output while copying a file is verbose and not
machine-parseable, you may want to use --json in combination with
diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn
index 6975e4a..7074ca5 100644
--- a/doc/git-annex-drop.mdwn
+++ b/doc/git-annex-drop.mdwn
@@ -82,6 +82,11 @@ safe to do so.
Enables batch mode, in which lines containing names of files to drop
are read from stdin.
+ As each specified file is processed, the usual output is
+ displayed. If a file's content is not present, or it does not
+ match specified matching options, or it is not an annexed file,
+ a blank line is output in response instead.
+
* `--json`
Enable JSON output. This is intended to be parsed by programs that use
diff --git a/doc/git-annex-export.mdwn b/doc/git-annex-export.mdwn
index 1d7170c..95f56e0 100644
--- a/doc/git-annex-export.mdwn
+++ b/doc/git-annex-export.mdwn
@@ -38,6 +38,13 @@ verification of content downloaded from an export. Some types of keys,
that are not based on checksums, cannot be downloaded from an export.
And, git-annex will never trust an export to retain the content of a key.
+However, some special remotes, notably S3, support keeping track of old
+versions of files stored in them. If a special remote is set up to do
+that, it can be used as a key/value store and the limitations in the above
+paragraph do not appy. Note that dropping content from such a remote is
+not supported. See individual special remotes' documentation for
+details of how to enable such versioning.
+
# OPTIONS
* `--to=remote`
diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn
index 89c5388..1287fa1 100644
--- a/doc/git-annex-get.mdwn
+++ b/doc/git-annex-get.mdwn
@@ -90,7 +90,8 @@ or transferring them from some kind of key-value store.
are read from stdin.
As each specified file is processed, the usual progress output is
- displayed. If the specified file's content is already present, or
+ displayed. If the specified file's content is already present,
+ or it does not match specified matching options, or
it is not an annexed file, a blank line is output in response instead.
Since the usual output while getting a file is verbose and not
diff --git a/doc/git-annex-metadata.mdwn b/doc/git-annex-metadata.mdwn
index 5e86077..a672b10 100644
--- a/doc/git-annex-metadata.mdwn
+++ b/doc/git-annex-metadata.mdwn
@@ -152,6 +152,9 @@ automatically.
{"file":"foo","fields":{"author":[]}}
+ Note that file matching options do not affect the files that are
+ processed when in batch mode.
+
# EXAMPLES
To set some tags on a file and also its author:
diff --git a/doc/git-annex-move.mdwn b/doc/git-annex-move.mdwn
index 661edba..3af858f 100644
--- a/doc/git-annex-move.mdwn
+++ b/doc/git-annex-move.mdwn
@@ -80,7 +80,8 @@ Moves the content of files from or to another remote.
are read from stdin.
As each specified file is processed, the usual progress output is
- displayed. If a file's content does not need to be moved or it
+ displayed. If a file's content does not need to be moved,
+ or it does not match specified matching options, or it
is not an annexed file, a blank line is output in response instead.
Since the usual output while moving a file is verbose and not
diff --git a/doc/git-annex-whereis.mdwn b/doc/git-annex-whereis.mdwn
index 9822c57..5c3a774 100644
--- a/doc/git-annex-whereis.mdwn
+++ b/doc/git-annex-whereis.mdwn
@@ -48,7 +48,8 @@ For example:
Enables batch mode, in which a file is read in a line from stdin,
its information displayed, and repeat.
- Note that if the file is not an annexed file, an empty line will be
+ Note that if the file is not an annexed file, or does not match
+ specified file matching options, an empty line will be
output instead.
* `--json`
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 09b4ef3..ad1e7b4 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -1296,10 +1296,10 @@ Here are all the supported configuration settings.
* `remote.<name>.annex-speculate-present`
- Make git-annex speculate that this remote may contain the content of any
- file, even though its normal location tracking does not indicate that it
- does. This will cause git-annex to try to get all file contents from the
- remote. Can be useful in setting up a caching remote.
+ Set to "true" to make git-annex speculate that this remote may contain the
+ content of any file, even though its normal location tracking does not
+ indicate that it does. This will cause git-annex to try to get all file
+ contents from the remote. Can be useful in setting up a caching remote.
* `remote.<name>.annex-bare`
diff --git a/git-annex.cabal b/git-annex.cabal
index 2f58d6d..eeffa2f 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 6.20180807
+Version: 6.20180913
Cabal-Version: >= 1.8
License: GPL-3
Maintainer: Joey Hess <id@joeyh.name>
@@ -364,6 +364,7 @@ Executable git-annex
cryptonite,
memory,
split,
+ attoparsec,
QuickCheck (>= 2.1),
tasty (>= 0.7),
tasty-hunit,
@@ -415,12 +416,91 @@ Executable git-annex
Other-Modules:
Remote.WebDAV
Remote.WebDAV.DavLocation
+ if flag(S3) || flag(WebDAV)
+ Other-Modules:
+ Remote.Helper.Http
if flag(Assistant) && ! os(solaris) && ! os(gnu)
- Build-Depends: dns (>= 1.0.0), mountpoints
+ Build-Depends: mountpoints
CPP-Options: -DWITH_ASSISTANT
+ Other-Modules:
+ Assistant
+ Assistant.Alert
+ Assistant.Alert.Utility
+ Assistant.BranchChange
+ Assistant.Changes
+ Assistant.Commits
+ Assistant.Common
+ Assistant.CredPairCache
+ Assistant.DaemonStatus
+ Assistant.DeleteRemote
+ Assistant.Drop
+ Assistant.Fsck
+ Assistant.Gpg
+ Assistant.Install
+ Assistant.Install.AutoStart
+ Assistant.Install.Menu
+ Assistant.MakeRemote
+ Assistant.Monad
+ Assistant.NamedThread
+ Assistant.Pairing
+ Assistant.Pairing.MakeRemote
+ Assistant.Pairing.Network
+ Assistant.Pushes
+ Assistant.RemoteControl
+ Assistant.Repair
+ Assistant.RepoProblem
+ Assistant.Restart
+ Assistant.ScanRemotes
+ Assistant.Ssh
+ Assistant.Sync
+ Assistant.Threads.Committer
+ Assistant.Threads.ConfigMonitor
+ Assistant.Threads.Cronner
+ Assistant.Threads.DaemonStatus
+ Assistant.Threads.Exporter
+ Assistant.Threads.Glacier
+ Assistant.Threads.Merger
+ Assistant.Threads.MountWatcher
+ Assistant.Threads.NetWatcher
+ Assistant.Threads.ProblemFixer
+ Assistant.Threads.Pusher
+ Assistant.Threads.RemoteControl
+ Assistant.Threads.SanityChecker
+ Assistant.Threads.TransferPoller
+ Assistant.Threads.TransferScanner
+ Assistant.Threads.TransferWatcher
+ Assistant.Threads.Transferrer
+ Assistant.Threads.UpgradeWatcher
+ Assistant.Threads.Upgrader
+ Assistant.Threads.Watcher
+ Assistant.TransferQueue
+ Assistant.TransferSlots
+ Assistant.TransferrerPool
+ Assistant.Types.Alert
+ Assistant.Types.BranchChange
+ Assistant.Types.Changes
+ Assistant.Types.Commits
+ Assistant.Types.CredPairCache
+ Assistant.Types.DaemonStatus
+ Assistant.Types.NamedThread
+ Assistant.Types.Pushes
+ Assistant.Types.RemoteControl
+ Assistant.Types.RepoProblem
+ Assistant.Types.ScanRemotes
+ Assistant.Types.ThreadName
+ Assistant.Types.ThreadedMonad
+ Assistant.Types.TransferQueue
+ Assistant.Types.TransferSlots
+ Assistant.Types.TransferrerPool
+ Assistant.Types.UrlRenderer
+ Assistant.Unused
+ Assistant.Upgrade
+ Command.Assistant
+ Command.Watch
+ Utility.Mounts
+ Utility.OSX
- if flag(Assistant)
if os(linux) || flag(Android)
Build-Depends: hinotify
CPP-Options: -DWITH_INOTIFY
@@ -429,7 +509,8 @@ Executable git-annex
if os(darwin)
Build-Depends: hfsevents
CPP-Options: -DWITH_FSEVENTS
- Other-Modules: Utility.DirWatcher.FSEvents
+ Other-Modules:
+ Utility.DirWatcher.FSEvents
else
if os(windows)
Build-Depends: Win32-notify
@@ -550,6 +631,8 @@ Executable git-annex
Annex.Concurrent
Annex.Content
Annex.Content.Direct
+ Annex.Content.LowLevel
+ Annex.Content.PointerFile
Annex.Difference
Annex.DirHashes
Annex.Direct
@@ -594,78 +677,6 @@ Executable git-annex
Annex.Wanted
Annex.WorkTree
Annex.YoutubeDl
- Assistant
- Assistant.Alert
- Assistant.Alert.Utility
- Assistant.BranchChange
- Assistant.Changes
- Assistant.Commits
- Assistant.Common
- Assistant.CredPairCache
- Assistant.DaemonStatus
- Assistant.DeleteRemote
- Assistant.Drop
- Assistant.Fsck
- Assistant.Gpg
- Assistant.Install
- Assistant.Install.AutoStart
- Assistant.Install.Menu
- Assistant.MakeRemote
- Assistant.Monad
- Assistant.NamedThread
- Assistant.Pairing
- Assistant.Pairing.MakeRemote
- Assistant.Pairing.Network
- Assistant.Pushes
- Assistant.RemoteControl
- Assistant.Repair
- Assistant.RepoProblem
- Assistant.Restart
- Assistant.ScanRemotes
- Assistant.Ssh
- Assistant.Sync
- Assistant.Threads.Committer
- Assistant.Threads.ConfigMonitor
- Assistant.Threads.Cronner
- Assistant.Threads.DaemonStatus
- Assistant.Threads.Exporter
- Assistant.Threads.Glacier
- Assistant.Threads.Merger
- Assistant.Threads.MountWatcher
- Assistant.Threads.NetWatcher
- Assistant.Threads.ProblemFixer
- Assistant.Threads.Pusher
- Assistant.Threads.RemoteControl
- Assistant.Threads.SanityChecker
- Assistant.Threads.TransferPoller
- Assistant.Threads.TransferScanner
- Assistant.Threads.TransferWatcher
- Assistant.Threads.Transferrer
- Assistant.Threads.UpgradeWatcher
- Assistant.Threads.Upgrader
- Assistant.Threads.Watcher
- Assistant.TransferQueue
- Assistant.TransferSlots
- Assistant.TransferrerPool
- Assistant.Types.Alert
- Assistant.Types.BranchChange
- Assistant.Types.Changes
- Assistant.Types.Commits
- Assistant.Types.CredPairCache
- Assistant.Types.DaemonStatus
- Assistant.Types.NamedThread
- Assistant.Types.Pushes
- Assistant.Types.RemoteControl
- Assistant.Types.RepoProblem
- Assistant.Types.ScanRemotes
- Assistant.Types.ThreadName
- Assistant.Types.ThreadedMonad
- Assistant.Types.TransferQueue
- Assistant.Types.TransferSlots
- Assistant.Types.TransferrerPool
- Assistant.Types.UrlRenderer
- Assistant.Unused
- Assistant.Upgrade
Backend
Backend.Hash
Backend.URL
@@ -697,7 +708,6 @@ Executable git-annex
Command.AddUnused
Command.AddUrl
Command.Adjust
- Command.Assistant
Command.CalcKey
Command.CheckPresentKey
Command.Commit
@@ -798,7 +808,6 @@ Executable git-annex
Command.Vicfg
Command.View
Command.Wanted
- Command.Watch
Command.Whereis
Common
Config
@@ -806,6 +815,7 @@ Executable git-annex
Config.Files
Config.DynamicConfig
Config.GitConfig
+ Config.Smudge
Creds
Crypto
Database.Export
@@ -879,6 +889,7 @@ Executable git-annex
Logs.Location
Logs.MapLog
Logs.MetaData
+ Logs.MetaData.Pure
Logs.Multicast
Logs.NumCopies
Logs.PreferredContent
@@ -889,6 +900,7 @@ Executable git-annex
Logs.RemoteState
Logs.Schedule
Logs.SingleValue
+ Logs.SingleValue.Pure
Logs.TimeStamp
Logs.Transfer
Logs.Transitions
@@ -929,7 +941,6 @@ Executable git-annex
Remote.Helper.Export
Remote.Helper.Git
Remote.Helper.Hooks
- Remote.Helper.Http
Remote.Helper.Messages
Remote.Helper.P2P
Remote.Helper.ReadOnly
@@ -1017,7 +1028,6 @@ Executable git-annex
Utility.Env.Basic
Utility.Env.Set
Utility.Exception
- Utility.ExternalSHA
Utility.FileMode
Utility.FileSize
Utility.FileSystemEncoding
@@ -1047,10 +1057,8 @@ Executable git-annex
Utility.Metered
Utility.Misc
Utility.Monad
- Utility.Mounts
Utility.Network
Utility.NotificationBroadcaster
- Utility.OSX
Utility.OptParse
Utility.PID
Utility.Parallel
@@ -1063,7 +1071,6 @@ Executable git-annex
Utility.Process.Transcript
Utility.QuickCheck
Utility.Rsync
- Utility.SRV
Utility.SafeCommand
Utility.Scheduled
Utility.Scheduled.QuickCheck