1002 lines
32 KiB
Haskell
1002 lines
32 KiB
Haskell
{- git-annex file content managing
|
||
-
|
||
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
|
||
-
|
||
- Licensed under the GNU GPL version 3 or higher.
|
||
-}
|
||
|
||
{-# LANGUAGE CPP #-}
|
||
|
||
module Annex.Content (
|
||
inAnnex,
|
||
inAnnex',
|
||
inAnnexSafe,
|
||
inAnnexCheck,
|
||
objectFileExists,
|
||
lockContentShared,
|
||
lockContentForRemoval,
|
||
ContentRemovalLock,
|
||
RetrievalSecurityPolicy(..),
|
||
getViaTmp,
|
||
getViaTmpFromDisk,
|
||
checkDiskSpaceToGet,
|
||
prepTmp,
|
||
withTmp,
|
||
checkDiskSpace,
|
||
needMoreDiskSpace,
|
||
moveAnnex,
|
||
populatePointerFile,
|
||
linkToAnnex,
|
||
linkFromAnnex,
|
||
LinkAnnexResult(..),
|
||
unlinkAnnex,
|
||
checkedCopyFile,
|
||
linkOrCopy,
|
||
linkOrCopy',
|
||
sendAnnex,
|
||
prepSendAnnex,
|
||
removeAnnex,
|
||
moveBad,
|
||
KeyLocation(..),
|
||
getKeysPresent,
|
||
saveState,
|
||
downloadUrl,
|
||
preseedTmp,
|
||
dirKeys,
|
||
withObjectLoc,
|
||
staleKeysPrune,
|
||
pruneTmpWorkDirBefore,
|
||
isUnmodified,
|
||
isUnmodifiedCheap,
|
||
verifyKeyContent,
|
||
VerifyConfig(..),
|
||
Verification(..),
|
||
unVerified,
|
||
withTmpWorkDir,
|
||
) where
|
||
|
||
import System.IO.Unsafe (unsafeInterleaveIO)
|
||
import qualified Data.Set as S
|
||
|
||
import Annex.Common
|
||
import Logs.Location
|
||
import Types.Transfer
|
||
import Logs.Transfer
|
||
import qualified Git
|
||
import qualified Annex
|
||
import qualified Annex.Queue
|
||
import qualified Annex.Branch
|
||
import Utility.FileMode
|
||
import qualified Annex.Url as Url
|
||
import Utility.CopyFile
|
||
import Utility.Metered
|
||
import Config
|
||
import Git.FilePath
|
||
import Annex.Perms
|
||
import Annex.Link
|
||
import qualified Annex.Content.Direct as Direct
|
||
import Annex.ReplaceFile
|
||
import Annex.LockPool
|
||
import Messages.Progress
|
||
import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..))
|
||
import qualified Types.Remote
|
||
import qualified Types.Backend
|
||
import qualified Backend
|
||
import qualified Database.Keys
|
||
import Types.NumCopies
|
||
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
|
||
inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
|
||
|
||
{- Runs an arbitrary check on a key's content. -}
|
||
inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
|
||
inAnnexCheck key check = inAnnex' id False check key
|
||
|
||
{- inAnnex that performs an arbitrary check of the key's content. -}
|
||
inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
|
||
inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
|
||
where
|
||
checkindirect loc = do
|
||
r <- check loc
|
||
if isgood r
|
||
then ifM (annexThin <$> Annex.getGitConfig)
|
||
-- When annex.thin is set, the object file
|
||
-- could be modified; make sure it's not.
|
||
-- (Suppress any messages about
|
||
-- checksumming, to avoid them cluttering
|
||
-- the display.)
|
||
( ifM (doQuietAction $ isUnmodified key loc)
|
||
( return r
|
||
, return bad
|
||
)
|
||
, return r
|
||
)
|
||
else return bad
|
||
|
||
-- In direct mode, at least one of the associated files must pass the
|
||
-- check. Additionally, the file must be unmodified.
|
||
checkdirect [] = return bad
|
||
checkdirect (loc:locs) = do
|
||
r <- check loc
|
||
if isgood r
|
||
then ifM (Direct.goodContent key loc)
|
||
( return r
|
||
, checkdirect locs
|
||
)
|
||
else checkdirect locs
|
||
|
||
{- Like inAnnex, checks if the object file for a key exists,
|
||
- but there are no guarantees it has the right content. -}
|
||
objectFileExists :: Key -> Annex Bool
|
||
objectFileExists key = calcRepo (gitAnnexLocation key) >>= liftIO . doesFileExist
|
||
|
||
{- A safer check; the key's content must not only be present, but
|
||
- is not in the process of being removed. -}
|
||
inAnnexSafe :: Key -> Annex (Maybe Bool)
|
||
inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key
|
||
where
|
||
is_locked = Nothing
|
||
is_unlocked = Just True
|
||
is_missing = Just False
|
||
|
||
go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
|
||
=<< contentLockFile key
|
||
|
||
#ifndef mingw32_HOST_OS
|
||
checkindirect contentfile = checkOr is_missing contentfile
|
||
{- In direct mode, the content file must exist, but
|
||
- the lock file generally won't exist unless a removal is in
|
||
- process. -}
|
||
checkdirect contentfile lockfile =
|
||
ifM (liftIO $ doesFileExist contentfile)
|
||
( checkOr is_unlocked lockfile
|
||
, return is_missing
|
||
)
|
||
checkOr d lockfile = checkLocked lockfile >>= return . \case
|
||
Nothing -> d
|
||
Just True -> is_locked
|
||
Just False -> is_unlocked
|
||
#else
|
||
checkindirect f = liftIO $ ifM (doesFileExist f)
|
||
( lockShared f >>= \case
|
||
Nothing -> return is_locked
|
||
Just lockhandle -> do
|
||
dropLock lockhandle
|
||
return is_unlocked
|
||
, return is_missing
|
||
)
|
||
{- In Windows, see if we can take a shared lock. If so,
|
||
- remove the lock file to clean up after ourselves. -}
|
||
checkdirect contentfile lockfile =
|
||
ifM (liftIO $ doesFileExist contentfile)
|
||
( modifyContent lockfile $ liftIO $
|
||
lockShared lockfile >>= \case
|
||
Nothing -> return is_locked
|
||
Just lockhandle -> do
|
||
dropLock lockhandle
|
||
void $ tryIO $ nukeFile lockfile
|
||
return is_unlocked
|
||
, return is_missing
|
||
)
|
||
#endif
|
||
|
||
{- Direct mode and especially Windows has to use a separate lock
|
||
- file from the content, since locking the actual content file
|
||
- would interfere with the user's use of it. -}
|
||
contentLockFile :: Key -> Annex (Maybe FilePath)
|
||
#ifndef mingw32_HOST_OS
|
||
contentLockFile key = ifM isDirect
|
||
( Just <$> calcRepo (gitAnnexContentLock key)
|
||
, return Nothing
|
||
)
|
||
#else
|
||
contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
|
||
#endif
|
||
|
||
{- Prevents the content from being removed while the action is running.
|
||
- Uses a shared lock.
|
||
-
|
||
- If locking fails, or the content is not present, throws an exception
|
||
- rather than running the action.
|
||
-
|
||
- Note that, in direct mode, nothing prevents the user from directly
|
||
- editing or removing the content, even while it's locked by this.
|
||
-}
|
||
lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
|
||
lockContentShared key a = lockContentUsing lock key $ ifM (inAnnex key)
|
||
( do
|
||
u <- getUUID
|
||
withVerifiedCopy LockedCopy u (return True) a
|
||
, giveup $ "failed to lock content: not present"
|
||
)
|
||
where
|
||
#ifndef mingw32_HOST_OS
|
||
lock contentfile Nothing = tryLockShared Nothing contentfile
|
||
lock _ (Just lockfile) = posixLocker tryLockShared lockfile
|
||
#else
|
||
lock = winLocker lockShared
|
||
#endif
|
||
|
||
{- Exclusively locks content, while performing an action that
|
||
- might remove it.
|
||
-
|
||
- If locking fails, throws an exception rather than running the action.
|
||
-}
|
||
lockContentForRemoval :: Key -> (ContentRemovalLock -> Annex a) -> Annex a
|
||
lockContentForRemoval key a = lockContentUsing lock key $
|
||
a (ContentRemovalLock key)
|
||
where
|
||
#ifndef mingw32_HOST_OS
|
||
{- Since content files are stored with the write bit disabled, have
|
||
- to fiddle with permissions to open for an exclusive lock. -}
|
||
lock contentfile Nothing = bracket_
|
||
(thawContent contentfile)
|
||
(freezeContent contentfile)
|
||
(tryLockExclusive Nothing contentfile)
|
||
lock _ (Just lockfile) = posixLocker tryLockExclusive lockfile
|
||
#else
|
||
lock = winLocker lockExclusive
|
||
#endif
|
||
|
||
{- Passed the object content file, and maybe a separate lock file to use,
|
||
- when the content file itself should not be locked. -}
|
||
type ContentLocker = FilePath -> Maybe LockFile -> Annex (Maybe LockHandle)
|
||
|
||
#ifndef mingw32_HOST_OS
|
||
posixLocker :: (Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle)
|
||
posixLocker takelock lockfile = do
|
||
mode <- annexFileMode
|
||
modifyContent lockfile $
|
||
takelock (Just mode) lockfile
|
||
|
||
#else
|
||
winLocker :: (LockFile -> IO (Maybe LockHandle)) -> ContentLocker
|
||
winLocker takelock _ (Just lockfile) = do
|
||
modifyContent lockfile $
|
||
void $ liftIO $ tryIO $
|
||
writeFile lockfile ""
|
||
liftIO $ takelock lockfile
|
||
-- never reached; windows always uses a separate lock file
|
||
winLocker _ _ Nothing = return Nothing
|
||
#endif
|
||
|
||
lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a
|
||
lockContentUsing locker key a = do
|
||
contentfile <- calcRepo $ gitAnnexLocation key
|
||
lockfile <- contentLockFile key
|
||
bracket
|
||
(lock contentfile lockfile)
|
||
(unlock lockfile)
|
||
(const a)
|
||
where
|
||
alreadylocked = giveup "content is locked"
|
||
failedtolock e = giveup $ "failed to lock content: " ++ show e
|
||
|
||
lock contentfile lockfile =
|
||
(maybe alreadylocked return
|
||
=<< locker contentfile lockfile)
|
||
`catchIO` failedtolock
|
||
|
||
#ifndef mingw32_HOST_OS
|
||
unlock mlockfile lck = do
|
||
maybe noop cleanuplockfile mlockfile
|
||
liftIO $ dropLock lck
|
||
#else
|
||
unlock mlockfile lck = do
|
||
-- Can't delete a locked file on Windows
|
||
liftIO $ dropLock lck
|
||
maybe noop cleanuplockfile mlockfile
|
||
#endif
|
||
|
||
cleanuplockfile lockfile = modifyContent lockfile $
|
||
void $ liftIO $ tryIO $
|
||
nukeFile lockfile
|
||
|
||
{- Runs an action, passing it the temp file to get,
|
||
- and if the action succeeds, verifies the file matches
|
||
- the key and moves the file into the annex as a key's content. -}
|
||
getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool
|
||
getViaTmp rsp v key action = checkDiskSpaceToGet key False $
|
||
getViaTmpFromDisk rsp v key action
|
||
|
||
{- Like getViaTmp, but does not check that there is enough disk space
|
||
- for the incoming key. For use when the key content is already on disk
|
||
- and not being copied into place. -}
|
||
getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool
|
||
getViaTmpFromDisk rsp v key action = checkallowed $ do
|
||
tmpfile <- prepTmp key
|
||
resuming <- liftIO $ doesFileExist tmpfile
|
||
(ok, verification) <- action tmpfile
|
||
-- When the temp file already had content, we don't know if
|
||
-- that content is good or not, so only trust if it the action
|
||
-- Verified it in passing. Otherwise, force verification even
|
||
-- if the VerifyConfig normally disables it.
|
||
let verification' = if resuming
|
||
then case verification of
|
||
Verified -> Verified
|
||
_ -> MustVerify
|
||
else verification
|
||
if ok
|
||
then ifM (verifyKeyContent rsp v verification' key tmpfile)
|
||
( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key))
|
||
( do
|
||
logStatus key InfoPresent
|
||
return True
|
||
, return False
|
||
)
|
||
, do
|
||
warning "verification of content failed"
|
||
-- The bad content is not retained, because
|
||
-- a retry should not try to resume from it
|
||
-- since it's apparently corrupted.
|
||
-- Also, the bad content could be any data,
|
||
-- including perhaps the content of another
|
||
-- file than the one that was requested,
|
||
-- and so it's best not to keep it on disk.
|
||
pruneTmpWorkDirBefore tmpfile (liftIO . nukeFile)
|
||
return False
|
||
)
|
||
-- On transfer failure, the tmp file is left behind, in case
|
||
-- caller wants to resume its transfer
|
||
else return False
|
||
where
|
||
-- Avoid running the action to get the content when the
|
||
-- RetrievalSecurityPolicy would cause verification to always fail.
|
||
checkallowed a = case rsp of
|
||
RetrievalAllKeysSecure -> a
|
||
RetrievalVerifiableKeysSecure
|
||
| isVerifiable (keyVariety key) -> a
|
||
| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
|
||
( a
|
||
, warnUnverifiableInsecure key >> return False
|
||
)
|
||
|
||
{- Verifies that a file is the expected content of a key.
|
||
-
|
||
- Configuration can prevent verification, for either a
|
||
- particular remote or always, unless the RetrievalSecurityPolicy
|
||
- requires verification.
|
||
-
|
||
- Most keys have a known size, and if so, the file size is checked.
|
||
-
|
||
- When the key's backend allows verifying the content (via checksum),
|
||
- it is checked.
|
||
-
|
||
- If the RetrievalSecurityPolicy requires verification and the key's
|
||
- backend doesn't support it, the verification will fail.
|
||
-}
|
||
verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> FilePath -> Annex Bool
|
||
verifyKeyContent rsp v verification k f = case (rsp, verification) of
|
||
(_, Verified) -> return True
|
||
(RetrievalVerifiableKeysSecure, _)
|
||
| isVerifiable (keyVariety k) -> verify
|
||
| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
|
||
( verify
|
||
, warnUnverifiableInsecure k >> return False
|
||
)
|
||
(_, UnVerified) -> ifM (shouldVerify v)
|
||
( verify
|
||
, return True
|
||
)
|
||
(_, MustVerify) -> verify
|
||
where
|
||
verify = verifysize <&&> verifycontent
|
||
verifysize = case keySize k of
|
||
Nothing -> return True
|
||
Just size -> do
|
||
size' <- liftIO $ catchDefaultIO 0 $ getFileSize f
|
||
return (size' == size)
|
||
verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (keyVariety k) of
|
||
Nothing -> return True
|
||
Just verifier -> verifier k f
|
||
|
||
warnUnverifiableInsecure :: Key -> Annex ()
|
||
warnUnverifiableInsecure k = warning $ unwords
|
||
[ "Getting " ++ kv ++ " keys with this remote is not secure;"
|
||
, "the content cannot be verified to be correct."
|
||
, "(Use annex.security.allow-unverified-downloads to bypass"
|
||
, "this safety check.)"
|
||
]
|
||
where
|
||
kv = decodeBS (formatKeyVariety (keyVariety k))
|
||
|
||
data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify
|
||
|
||
shouldVerify :: VerifyConfig -> Annex Bool
|
||
shouldVerify AlwaysVerify = return True
|
||
shouldVerify NoVerify = return False
|
||
shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig
|
||
shouldVerify (RemoteVerify r) =
|
||
(shouldVerify DefaultVerify
|
||
<&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r)))
|
||
-- Export remotes are not key/value stores, so always verify
|
||
-- content from them even when verification is disabled.
|
||
<||> Types.Remote.isExportSupported r
|
||
|
||
{- Checks if there is enough free disk space to download a key
|
||
- to its temp file.
|
||
-
|
||
- When the temp file already exists, count the space it is using as
|
||
- free, since the download will overwrite it or resume.
|
||
-
|
||
- Wen there's enough free space, runs the download action.
|
||
-}
|
||
checkDiskSpaceToGet :: Key -> a -> Annex a -> Annex a
|
||
checkDiskSpaceToGet key unabletoget getkey = do
|
||
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
|
||
|
||
e <- liftIO $ doesFileExist tmp
|
||
alreadythere <- liftIO $ if e
|
||
then getFileSize tmp
|
||
else return 0
|
||
ifM (checkDiskSpace Nothing key alreadythere True)
|
||
( do
|
||
-- The tmp file may not have been left writable
|
||
when e $ thawContent tmp
|
||
getkey
|
||
, return unabletoget
|
||
)
|
||
|
||
prepTmp :: Key -> Annex FilePath
|
||
prepTmp key = do
|
||
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
|
||
createAnnexDirectory (parentDir tmp)
|
||
return tmp
|
||
|
||
{- Prepares a temp file for a key, runs an action on it, and cleans up
|
||
- the temp file. If the action throws an exception, the temp file is
|
||
- left behind, which allows for resuming.
|
||
-}
|
||
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
|
||
withTmp key action = do
|
||
tmp <- prepTmp key
|
||
res <- action tmp
|
||
pruneTmpWorkDirBefore tmp (liftIO . nukeFile)
|
||
return res
|
||
|
||
{- 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
|
||
- various reasons; perhaps the same content is being annexed again.
|
||
- Perhaps there has been a hash collision generating the keys.
|
||
-
|
||
- The current strategy is to assume that in this case it's safe to delete
|
||
- one of the two copies of the content; and the one already in the annex
|
||
- is left there, assuming it's the original, canonical copy.
|
||
-
|
||
- I considered being more paranoid, and checking that both files had
|
||
- the same content. Decided against it because A) users explicitly choose
|
||
- a backend based on its hashing properties and so if they're dealing
|
||
- with colliding files it's their own fault and B) adding such a check
|
||
- would not catch all cases of colliding keys. For example, perhaps
|
||
- a remote has a key; if it's then added again with different content then
|
||
- the overall system now has two different peices of content for that
|
||
- key, and one of them will probably get deleted later. So, adding the
|
||
- check here would only raise expectations that git-annex cannot truely
|
||
- meet.
|
||
-
|
||
- May return false, when a particular variety of key is not being
|
||
- accepted into the repository. Will display a warning message in this
|
||
- case. May also throw exceptions in some cases.
|
||
-}
|
||
moveAnnex :: Key -> FilePath -> Annex Bool
|
||
moveAnnex key src = ifM (checkSecureHashes key)
|
||
( do
|
||
withObjectLoc key storeobject storedirect
|
||
return True
|
||
, return False
|
||
)
|
||
where
|
||
storeobject dest = ifM (liftIO $ doesFileExist dest)
|
||
( alreadyhave
|
||
, modifyContent dest $ do
|
||
freezeContent src
|
||
liftIO $ moveFile src dest
|
||
g <- Annex.gitRepo
|
||
fs <- map (`fromTopFilePath` g)
|
||
<$> Database.Keys.getAssociatedFiles key
|
||
unless (null fs) $ do
|
||
ics <- mapM (populatePointerFile (Restage True) key dest) fs
|
||
Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)
|
||
)
|
||
storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
|
||
|
||
{- In direct mode, the associated file's content may be locally
|
||
- modified. In that case, it's preserved. However, the content
|
||
- we're moving into the annex may be the only extant copy, so
|
||
- it's important we not lose it. So, when the key's content
|
||
- cannot be moved to any associated file, it's stored in indirect
|
||
- mode.
|
||
-}
|
||
storedirect = storedirect' storeindirect
|
||
storedirect' fallback [] = fallback
|
||
storedirect' fallback (f:fs) = do
|
||
thawContent src
|
||
v <- isAnnexLink f
|
||
if Just key == v
|
||
then do
|
||
Direct.updateInodeCache key src
|
||
replaceFile f $ liftIO . moveFile src
|
||
chmodContent f
|
||
forM_ fs $
|
||
Direct.addContentWhenNotPresent key f
|
||
else ifM (Direct.goodContent key f)
|
||
( storedirect' alreadyhave fs
|
||
, storedirect' fallback fs
|
||
)
|
||
|
||
alreadyhave = liftIO $ removeFile src
|
||
|
||
checkSecureHashes :: Key -> Annex Bool
|
||
checkSecureHashes key
|
||
| cryptographicallySecure (keyVariety key) = return True
|
||
| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
|
||
( do
|
||
warning $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key to annex objects"
|
||
return False
|
||
, return True
|
||
)
|
||
|
||
data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
|
||
|
||
{- Populates the annex object file by hard linking or copying a source
|
||
- file to it. -}
|
||
linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult
|
||
linkToAnnex key src srcic = ifM (checkSecureHashes key)
|
||
( do
|
||
dest <- calcRepo (gitAnnexLocation key)
|
||
modifyContent dest $ linkAnnex To key src srcic dest Nothing
|
||
, return LinkAnnexFailed
|
||
)
|
||
|
||
{- Makes a destination file be a link or copy from the annex object. -}
|
||
linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
|
||
linkFromAnnex key dest destmode = do
|
||
src <- calcRepo (gitAnnexLocation key)
|
||
srcic <- withTSDelta (liftIO . genInodeCache src)
|
||
linkAnnex From key src srcic dest destmode
|
||
|
||
data FromTo = From | To
|
||
|
||
{- Hard links or copies from or to the annex object location.
|
||
- Updates inode cache.
|
||
-
|
||
- 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.
|
||
-}
|
||
linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
|
||
linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed
|
||
linkAnnex fromto key src (Just srcic) dest destmode =
|
||
withTSDelta (liftIO . genInodeCache dest) >>= \case
|
||
Just destic -> do
|
||
cs <- Database.Keys.getInodeCaches key
|
||
if null cs
|
||
then Database.Keys.addInodeCaches key [srcic, destic]
|
||
else Database.Keys.addInodeCaches key [srcic]
|
||
return LinkAnnexNoop
|
||
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
|
||
where
|
||
failed = do
|
||
Database.Keys.addInodeCaches key [srcic]
|
||
return LinkAnnexFailed
|
||
checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case
|
||
Just srcic' | compareStrong srcic srcic' -> do
|
||
destic <- withTSDelta (liftIO . genInodeCache dest)
|
||
Database.Keys.addInodeCaches key $
|
||
catMaybes [destic, Just srcic]
|
||
return LinkAnnexOk
|
||
_ -> do
|
||
liftIO $ nukeFile dest
|
||
failed
|
||
|
||
{- Removes the annex object file for a key. Lowlevel. -}
|
||
unlinkAnnex :: Key -> Annex ()
|
||
unlinkAnnex key = do
|
||
obj <- calcRepo $ gitAnnexLocation key
|
||
modifyContent obj $ do
|
||
secureErase obj
|
||
liftIO $ nukeFile obj
|
||
|
||
{- 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.
|
||
- If this happens, runs the rollback action and returns False. The
|
||
- rollback action should remove the data that was transferred.
|
||
-}
|
||
sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool
|
||
sendAnnex key rollback sendobject = go =<< prepSendAnnex key
|
||
where
|
||
go Nothing = return False
|
||
go (Just (f, checksuccess)) = do
|
||
r <- sendobject f
|
||
ifM checksuccess
|
||
( return r
|
||
, do
|
||
rollback
|
||
return False
|
||
)
|
||
|
||
{- Returns a file that contains an object's content,
|
||
- and a check to run after the transfer is complete.
|
||
-
|
||
- When a file is unlocked (or in direct mode), it's possble for its
|
||
- content to change as it's being sent. The check detects this case
|
||
- and returns False.
|
||
-
|
||
- Note that the returned check action is, in some cases, run in the
|
||
- Annex monad of the remote that is receiving the object, rather than
|
||
- the sender. So it cannot rely on Annex state.
|
||
-}
|
||
prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
|
||
prepSendAnnex key = withObjectLoc key indirect direct
|
||
where
|
||
indirect f = do
|
||
cache <- Database.Keys.getInodeCaches key
|
||
cache' <- if null cache
|
||
-- Since no inode cache is in the database, this
|
||
-- object is not currently unlocked. But that could
|
||
-- change while the transfer is in progress, so
|
||
-- generate an inode cache for the starting
|
||
-- content.
|
||
then maybeToList <$>
|
||
withTSDelta (liftIO . genInodeCache f)
|
||
else pure cache
|
||
return $ if null cache'
|
||
then Nothing
|
||
else Just (f, sameInodeCache f cache')
|
||
direct [] = return Nothing
|
||
direct (f:fs) = do
|
||
cache <- Direct.recordedInodeCache key
|
||
-- check that we have a good file
|
||
ifM (sameInodeCache f cache)
|
||
( return $ Just (f, sameInodeCache f cache)
|
||
, direct fs
|
||
)
|
||
|
||
{- Performs an action, passing it the location to use for a key's content.
|
||
-
|
||
- In direct mode, the associated files will be passed. But, if there are
|
||
- no associated files for a key, the indirect mode action will be
|
||
- performed instead. -}
|
||
withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
|
||
withObjectLoc key indirect direct = ifM isDirect
|
||
( do
|
||
fs <- Direct.associatedFiles key
|
||
if null fs
|
||
then goindirect
|
||
else direct fs
|
||
, goindirect
|
||
)
|
||
where
|
||
goindirect = indirect =<< calcRepo (gitAnnexLocation key)
|
||
|
||
cleanObjectLoc :: Key -> Annex () -> Annex ()
|
||
cleanObjectLoc key cleaner = do
|
||
file <- calcRepo $ gitAnnexLocation key
|
||
void $ tryIO $ thawContentDir file
|
||
cleaner
|
||
liftIO $ removeparents file (3 :: Int)
|
||
where
|
||
removeparents _ 0 = noop
|
||
removeparents file n = do
|
||
let dir = parentDir file
|
||
maybe noop (const $ removeparents dir (n-1))
|
||
<=< catchMaybeIO $ removeDirectory dir
|
||
|
||
{- Removes a key's file from .git/annex/objects/
|
||
-}
|
||
removeAnnex :: ContentRemovalLock -> Annex ()
|
||
removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
|
||
where
|
||
remove file = cleanObjectLoc key $ do
|
||
secureErase file
|
||
liftIO $ nukeFile file
|
||
g <- Annex.gitRepo
|
||
mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g)
|
||
=<< 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)
|
||
( 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
|
||
replaceFile f $ makeAnnexLink l
|
||
|
||
{- Check if a file contains the unmodified content of the key.
|
||
-
|
||
- The expensive way to tell is to do a verification of its content.
|
||
- The cheaper way is to see if the InodeCache for the key matches the
|
||
- file. -}
|
||
isUnmodified :: Key -> FilePath -> Annex Bool
|
||
isUnmodified key f = go =<< geti
|
||
where
|
||
go Nothing = return False
|
||
go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc
|
||
expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f)
|
||
( do
|
||
-- The file could have been modified while it was
|
||
-- being verified. Detect that.
|
||
ifM (geti >>= maybe (return False) (compareInodeCaches fc))
|
||
( do
|
||
-- Update the InodeCache to avoid
|
||
-- performing this expensive check again.
|
||
Database.Keys.addInodeCaches key [fc]
|
||
return True
|
||
, return False
|
||
)
|
||
, return False
|
||
)
|
||
geti = withTSDelta (liftIO . genInodeCache f)
|
||
|
||
{- Cheap check if a file contains the unmodified content of the key,
|
||
- only checking the InodeCache of the key.
|
||
-
|
||
- Note that, on systems not supporting high-resolution mtimes,
|
||
- this may report a false positive when repeated edits are made to a file
|
||
- within a small time window (eg 1 second).
|
||
-}
|
||
isUnmodifiedCheap :: Key -> FilePath -> Annex Bool
|
||
isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key)
|
||
=<< withTSDelta (liftIO . genInodeCache f)
|
||
|
||
isUnmodifiedCheap' :: Key -> InodeCache -> Annex Bool
|
||
isUnmodifiedCheap' key fc =
|
||
anyM (compareInodeCaches fc) =<< Database.Keys.getInodeCaches key
|
||
|
||
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
|
||
- returns the file it was moved to. -}
|
||
moveBad :: Key -> Annex FilePath
|
||
moveBad key = do
|
||
src <- calcRepo $ gitAnnexLocation key
|
||
bad <- fromRepo gitAnnexBadDir
|
||
let dest = bad </> takeFileName src
|
||
createAnnexDirectory (parentDir dest)
|
||
cleanObjectLoc key $
|
||
liftIO $ moveFile src dest
|
||
logStatus key InfoMissing
|
||
return dest
|
||
|
||
data KeyLocation = InAnnex | InRepository | InAnywhere
|
||
|
||
{- List of keys whose content exists in the specified location.
|
||
|
||
- InAnnex only lists keys with content in .git/annex/objects,
|
||
- while InRepository, in direct mode, also finds keys with content
|
||
- in the work tree. InAnywhere lists all keys that have directories
|
||
- in .git/annex/objects, whether or not the content is present.
|
||
-
|
||
- Note that InRepository has to check whether direct mode files
|
||
- have goodContent.
|
||
-}
|
||
getKeysPresent :: KeyLocation -> Annex [Key]
|
||
getKeysPresent keyloc = do
|
||
direct <- isDirect
|
||
dir <- fromRepo gitAnnexObjectDir
|
||
s <- getstate direct
|
||
depth <- gitAnnexLocationDepth <$> Annex.getGitConfig
|
||
liftIO $ walk s direct depth dir
|
||
where
|
||
walk s direct depth dir = do
|
||
contents <- catchDefaultIO [] (dirContents dir)
|
||
if depth < 2
|
||
then do
|
||
contents' <- filterM (present s direct) contents
|
||
let keys = mapMaybe (fileKey . takeFileName) contents'
|
||
continue keys []
|
||
else do
|
||
let deeper = walk s direct (depth - 1)
|
||
continue [] (map deeper contents)
|
||
continue keys [] = return keys
|
||
continue keys (a:as) = do
|
||
{- Force lazy traversal with unsafeInterleaveIO. -}
|
||
morekeys <- unsafeInterleaveIO a
|
||
continue (morekeys++keys) as
|
||
|
||
inanywhere = case keyloc of
|
||
InAnywhere -> True
|
||
_ -> False
|
||
|
||
present _ _ _ | inanywhere = pure True
|
||
present _ False d = presentInAnnex d
|
||
present s True d = presentDirect s d <||> presentInAnnex d
|
||
|
||
presentInAnnex = doesFileExist . contentfile
|
||
contentfile d = d </> takeFileName d
|
||
|
||
presentDirect s d = case keyloc of
|
||
InAnnex -> return False
|
||
InRepository -> case fileKey (takeFileName d) of
|
||
Nothing -> return False
|
||
Just k -> Annex.eval s $
|
||
anyM (Direct.goodContent k) =<< Direct.associatedFiles k
|
||
InAnywhere -> return True
|
||
|
||
{- In order to run Annex monad actions within unsafeInterleaveIO,
|
||
- the current state is taken and reused. No changes made to this
|
||
- state will be preserved.
|
||
-
|
||
- As an optimsation, call inodesChanged to prime the state with
|
||
- a cached value that will be used in the call to goodContent.
|
||
-}
|
||
getstate direct = do
|
||
when direct $
|
||
void inodesChanged
|
||
Annex.getState id
|
||
|
||
{- Things to do to record changes to content when shutting down.
|
||
-
|
||
- It's acceptable to avoid committing changes to the branch,
|
||
- especially if performing a short-lived action.
|
||
-}
|
||
saveState :: Bool -> Annex ()
|
||
saveState nocommit = doSideAction $ do
|
||
Annex.Queue.flush
|
||
Database.Keys.closeDb
|
||
unless nocommit $
|
||
whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
|
||
Annex.Branch.commit =<< Annex.Branch.commitMessage
|
||
|
||
{- Downloads content from any of a list of urls, displaying a progress
|
||
- meter. -}
|
||
downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool
|
||
downloadUrl k p urls file =
|
||
-- Poll the file to handle configurations where an external
|
||
-- download command is used.
|
||
meteredFile file (Just p) k $
|
||
Url.withUrlOptions $ \uo ->
|
||
liftIO $ anyM (\u -> Url.download p u file uo) urls
|
||
|
||
{- Copies a key's content, when present, to a temp file.
|
||
- This is used to speed up some rsyncs. -}
|
||
preseedTmp :: Key -> FilePath -> Annex Bool
|
||
preseedTmp key file = go =<< inAnnex key
|
||
where
|
||
go False = return False
|
||
go True = do
|
||
ok <- copy
|
||
when ok $ thawContent file
|
||
return ok
|
||
copy = ifM (liftIO $ doesFileExist file)
|
||
( return True
|
||
, do
|
||
s <- calcRepo $ gitAnnexLocation key
|
||
liftIO $ ifM (doesFileExist s)
|
||
( copyFileExternal CopyTimeStamps s file
|
||
, return False
|
||
)
|
||
)
|
||
|
||
{- Finds files directly inside a directory like gitAnnexBadDir
|
||
- (not in subdirectories) and returns the corresponding keys. -}
|
||
dirKeys :: (Git.Repo -> FilePath) -> Annex [Key]
|
||
dirKeys dirspec = do
|
||
dir <- fromRepo dirspec
|
||
ifM (liftIO $ doesDirectoryExist dir)
|
||
( do
|
||
contents <- liftIO $ getDirectoryContents dir
|
||
files <- liftIO $ filterM doesFileExist $
|
||
map (dir </>) contents
|
||
return $ mapMaybe (fileKey . takeFileName) files
|
||
, return []
|
||
)
|
||
|
||
{- Looks in the specified directory for bad/tmp keys, and returns a list
|
||
- of those that might still have value, or might be stale and removable.
|
||
-
|
||
- Also, stale keys that can be proven to have no value
|
||
- (ie, their content is already present) are deleted.
|
||
-}
|
||
staleKeysPrune :: (Git.Repo -> FilePath) -> Bool -> Annex [Key]
|
||
staleKeysPrune dirspec nottransferred = do
|
||
contents <- dirKeys dirspec
|
||
|
||
dups <- filterM inAnnex contents
|
||
let stale = contents `exclude` dups
|
||
|
||
dir <- fromRepo dirspec
|
||
forM_ dups $ \k ->
|
||
pruneTmpWorkDirBefore (dir </> keyFile k) (liftIO . removeFile)
|
||
|
||
if nottransferred
|
||
then do
|
||
inprogress <- S.fromList . map (transferKey . fst)
|
||
<$> getTransfers
|
||
return $ filter (`S.notMember` inprogress) stale
|
||
else return stale
|
||
|
||
{- Prune the work dir associated with the specified content file,
|
||
- before performing an action that deletes the file, or moves it away.
|
||
-
|
||
- This preserves the invariant that the workdir never exists without
|
||
- the content file.
|
||
-}
|
||
pruneTmpWorkDirBefore :: FilePath -> (FilePath -> Annex a) -> Annex a
|
||
pruneTmpWorkDirBefore f action = do
|
||
let workdir = gitAnnexTmpWorkDir f
|
||
liftIO $ whenM (doesDirectoryExist workdir) $
|
||
removeDirectoryRecursive workdir
|
||
action f
|
||
|
||
{- Runs an action, passing it a temporary work directory where
|
||
- it can write files while receiving the content of a key.
|
||
-
|
||
- Preserves the invariant that the workdir never exists without the
|
||
- content file, by creating an empty content file first.
|
||
-
|
||
- On exception, or when the action returns Nothing,
|
||
- the temporary work directory is retained (unless
|
||
- empty), so anything in it can be used on resume.
|
||
-}
|
||
withTmpWorkDir :: Key -> (FilePath -> Annex (Maybe a)) -> Annex (Maybe a)
|
||
withTmpWorkDir key action = do
|
||
-- Create the object file if it does not exist. This way,
|
||
-- staleKeysPrune only has to look for object files, and can
|
||
-- clean up gitAnnexTmpWorkDir for those it finds.
|
||
obj <- prepTmp key
|
||
unlessM (liftIO $ doesFileExist obj) $ do
|
||
liftIO $ writeFile obj ""
|
||
setAnnexFilePerm obj
|
||
let tmpdir = gitAnnexTmpWorkDir obj
|
||
liftIO $ createDirectoryIfMissing True tmpdir
|
||
setAnnexDirPerm tmpdir
|
||
res <- action tmpdir
|
||
case res of
|
||
Just _ -> liftIO $ removeDirectoryRecursive tmpdir
|
||
Nothing -> liftIO $ void $ tryIO $ removeDirectory tmpdir
|
||
return res
|
||
|
||
{- Finds items in the first, smaller list, that are not
|
||
- present in the second, larger list.
|
||
-
|
||
- Constructing a single set, of the list that tends to be
|
||
- smaller, appears more efficient in both memory and CPU
|
||
- than constructing and taking the S.difference of two sets. -}
|
||
exclude :: Ord a => [a] -> [a] -> [a]
|
||
exclude [] _ = [] -- optimisation
|
||
exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
|
||
where
|
||
remove a b = foldl (flip S.delete) b a
|