From af6af352281263bc8d7da82431c49c67c770abec Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 16 Nov 2020 11:21:33 -0400 Subject: [PATCH] split out Annex.Content.Presence This will let a module that Annex.Content imports use inAnnex. Unsure yet if I will need that, but this split still seems to make sense, and Annex.Content was way too long so splitting it is good. --- Annex/Content.hs | 232 ++---------------------------------- Annex/Content/Presence.hs | 242 ++++++++++++++++++++++++++++++++++++++ git-annex.cabal | 1 + 3 files changed, 256 insertions(+), 219 deletions(-) create mode 100644 Annex/Content/Presence.hs diff --git a/Annex/Content.hs b/Annex/Content.hs index a8bcd1666a..e39351d781 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -60,132 +60,36 @@ import System.IO.Unsafe (unsafeInterleaveIO) import qualified Data.Set as S import Annex.Common -import Logs.Location -import Types.Transfer -import Logs.Transfer +import Annex.Content.Presence +import Annex.Content.LowLevel +import Annex.Content.PointerFile 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 qualified Backend +import qualified Database.Keys import Git.FilePath import Annex.Perms import Annex.Link import Annex.LockPool -import Annex.WorkerPool +import Annex.UUID +import Annex.InodeSentinal 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.Remote (RetrievalSecurityPolicy(..)) import Types.NumCopies import Types.Key -import Annex.UUID -import Annex.InodeSentinal +import Types.Transfer +import Logs.Transfer +import Logs.Location import Utility.InodeCache -import Annex.Content.LowLevel -import Annex.Content.PointerFile -import Types.WorkerPool +import Utility.CopyFile +import Utility.Metered import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P -{- Checks if a given key's content is currently present. -} -inAnnex :: Key -> Annex Bool -inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist - -{- Runs an arbitrary check on a key's content. -} -inAnnexCheck :: Key -> (RawFilePath -> 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 -> (RawFilePath -> Annex a) -> Key -> Annex a -inAnnex' isgood bad check key = withObjectLoc key $ \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 - -{- 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 . R.doesPathExist - -{- 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 = flip checklock contentfile =<< contentLockFile key - -#ifndef mingw32_HOST_OS - checklock Nothing contentfile = checkOr is_missing contentfile - {- The content file must exist, but the lock file generally - - won't exist unless a removal is in process. -} - checklock (Just lockfile) contentfile = - ifM (liftIO $ doesFileExist (fromRawFilePath 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 - checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile)) - ( lockShared contentfile >>= \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. -} - checklock (Just lockfile) contentfile = - ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) - ( modifyContent lockfile $ liftIO $ - lockShared lockfile >>= \case - Nothing -> return is_locked - Just lockhandle -> do - dropLock lockhandle - void $ tryIO $ removeWhenExistsWith removeLink lockfile - return is_unlocked - , return is_missing - ) -#endif - -{- 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 RawFilePath) -#ifndef mingw32_HOST_OS -contentLockFile _ = pure Nothing -#else -contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) -#endif - {- Prevents the content from being removed while the action is running. - Uses a shared lock. - @@ -357,71 +261,6 @@ getViaTmpFromDisk rsp v key action = checkallowed $ do ) ) -{- 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 -> RawFilePath -> Annex Bool -verifyKeyContent rsp v verification k f = case (rsp, verification) of - (_, Verified) -> return True - (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k) - ( verify - , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) - ( verify - , warnUnverifiableInsecure k >> return False - ) - ) - (_, UnVerified) -> ifM (shouldVerify v) - ( verify - , return True - ) - (_, MustVerify) -> verify - where - verify = enteringStage VerifyStage $ verifysize <&&> verifycontent - verifysize = case fromKey keySize k of - Nothing -> return True - Just size -> do - size' <- liftIO $ catchDefaultIO 0 $ getFileSize f - return (size' == size) - verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case - Nothing -> return True - Just b -> case Types.Backend.verifyKeyContent b 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 (fromKey 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. - @@ -648,10 +487,6 @@ prepSendAnnex key = withObjectLoc key $ \f -> do then Nothing else Just (fromRawFilePath f, sameInodeCache f cache') -{- Performs an action, passing it the location to use for a key's content. -} -withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a -withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) - cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do file <- calcRepo (gitAnnexLocation key) @@ -688,47 +523,6 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> , void $ tryIO $ thawContent file ) -{- 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 -> RawFilePath -> 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 -> RawFilePath -> 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 diff --git a/Annex/Content/Presence.hs b/Annex/Content/Presence.hs new file mode 100644 index 0000000000..3d05765fcb --- /dev/null +++ b/Annex/Content/Presence.hs @@ -0,0 +1,242 @@ +{- git-annex object content presence + - + - Copyright 2010-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content.Presence ( + inAnnex, + inAnnex', + inAnnexSafe, + inAnnexCheck, + objectFileExists, + withObjectLoc, + isUnmodified, + isUnmodifiedCheap, + verifyKeyContent, + VerifyConfig(..), + Verification(..), + unVerified, + warnUnverifiableInsecure, + contentLockFile, +) where + +import Annex.Common +import qualified Annex +import Annex.LockPool +import Annex.WorkerPool +import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) +import qualified Types.Remote +import qualified Types.Backend +import qualified Backend +import qualified Database.Keys +import Types.Key +import Annex.InodeSentinal +import Utility.InodeCache +import Types.WorkerPool +import qualified Utility.RawFilePath as R + +{- Checks if a given key's content is currently present. -} +inAnnex :: Key -> Annex Bool +inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist + +{- Runs an arbitrary check on a key's content. -} +inAnnexCheck :: Key -> (RawFilePath -> 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 -> (RawFilePath -> Annex a) -> Key -> Annex a +inAnnex' isgood bad check key = withObjectLoc key $ \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 + +{- 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 . R.doesPathExist + +{- 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 = flip checklock contentfile =<< contentLockFile key + +#ifndef mingw32_HOST_OS + checklock Nothing contentfile = checkOr is_missing contentfile + {- The content file must exist, but the lock file generally + - won't exist unless a removal is in process. -} + checklock (Just lockfile) contentfile = + ifM (liftIO $ doesFileExist (fromRawFilePath 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 + checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile)) + ( lockShared contentfile >>= \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. -} + checklock (Just lockfile) contentfile = + ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) + ( modifyContent lockfile $ liftIO $ + lockShared lockfile >>= \case + Nothing -> return is_locked + Just lockhandle -> do + dropLock lockhandle + void $ tryIO $ removeWhenExistsWith removeLink lockfile + return is_unlocked + , return is_missing + ) +#endif + +{- 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 RawFilePath) +#ifndef mingw32_HOST_OS +contentLockFile _ = pure Nothing +#else +contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) +#endif + +{- Performs an action, passing it the location to use for a key's content. -} +withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a +withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) + +{- 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 -> RawFilePath -> 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 -> RawFilePath -> 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 + +{- 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 -> RawFilePath -> Annex Bool +verifyKeyContent rsp v verification k f = case (rsp, verification) of + (_, Verified) -> return True + (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k) + ( verify + , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) + ( verify + , warnUnverifiableInsecure k >> return False + ) + ) + (_, UnVerified) -> ifM (shouldVerify v) + ( verify + , return True + ) + (_, MustVerify) -> verify + where + verify = enteringStage VerifyStage $ verifysize <&&> verifycontent + verifysize = case fromKey keySize k of + Nothing -> return True + Just size -> do + size' <- liftIO $ catchDefaultIO 0 $ getFileSize f + return (size' == size) + verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case + Nothing -> return True + Just b -> case Types.Backend.verifyKeyContent b 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 (fromKey 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 diff --git a/git-annex.cabal b/git-annex.cabal index 38ed97d46a..f2dc13ec20 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -623,6 +623,7 @@ Executable git-annex Annex.Concurrent Annex.Concurrent.Utility Annex.Content + Annex.Content.Presence Annex.Content.LowLevel Annex.Content.PointerFile Annex.CurrentBranch -- 2.30.2