diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -200,7 +200,7 @@ , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) , urloptions :: Maybe UrlOptions , insmudgecleanfilter :: Bool - , getvectorclock :: IO VectorClock + , getvectorclock :: IO CandidateVectorClock } newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState @@ -401,7 +401,7 @@ addGitConfigOverride :: String -> Annex () addGitConfigOverride v = do adjustGitRepo $ \r -> - Git.Config.store (encodeBS' v) Git.Config.ConfigList $ + Git.Config.store (encodeBS v) Git.Config.ConfigList $ r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) } changeState $ \st -> st { gitconfigoverride = v : gitconfigoverride st } where diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -84,6 +84,7 @@ import qualified Annex import Annex.Hook import Utility.Directory.Stream +import Utility.Tmp import qualified Utility.RawFilePath as R {- Name of the branch that is used to store git-annex's information. -} @@ -596,7 +597,7 @@ mapM_ (removeFile . (dir )) stagedfs hClose jlogh removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf) - openjlog tmpdir = liftIO $ openTempFile tmpdir "jlog" + openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog" {- This is run after the refs have been merged into the index, - but before the result is committed to the branch. diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -53,7 +53,8 @@ isUnmodifiedCheap, verifyKeyContentPostRetrieval, verifyKeyContent, - VerifyConfig(..), + VerifyConfig, + VerifyConfigA(..), Verification(..), unVerified, withTmpWorkDir, @@ -83,7 +84,7 @@ import Annex.ReplaceFile import Annex.AdjustedBranch (adjustedBranchRefresh) import Messages.Progress -import Types.Remote (RetrievalSecurityPolicy(..)) +import Types.Remote (RetrievalSecurityPolicy(..), VerifyConfigA(..)) import Types.NumCopies import Types.Key import Types.Transfer @@ -631,20 +632,39 @@ 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 -> Url.UrlOptions -> Annex Bool -downloadUrl k p urls file uo = + - meter. + - + - Only displays error message if all the urls fail to download. + - When listfailedurls is set, lists each url and why it failed. + - Otherwise, only displays one error message, from one of the urls + - that failed. + -} +downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool +downloadUrl listfailedurls k p iv urls file uo = -- Poll the file to handle configurations where an external -- download command is used. - meteredFile file (Just p) k (go urls Nothing) + meteredFile file (Just p) k (go urls []) where - -- Display only one error message, if all the urls fail to - -- download. - go [] (Just err) = warning err >> return False - go [] Nothing = return False - go (u:us) _ = Url.download' p u file uo >>= \case + go (u:us) errs = Url.download' p iv u file uo >>= \case Right () -> return True - Left err -> go us (Just err) + Left err -> do + -- If the incremental verifier was fed anything + -- while the download that failed ran, it's unable + -- to be used for the other urls. + case iv of + Just iv' -> + liftIO $ positionIncremental iv' >>= \case + Just n | n > 0 -> unableIncremental iv' + _ -> noop + Nothing -> noop + go us ((u, err) : errs) + go [] [] = return False + go [] errs@((_, err):_) = do + if listfailedurls + then warning $ unlines $ flip map errs $ \(u, err') -> + u ++ " " ++ err' + else warning err + return False {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -} diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -10,32 +10,16 @@ module Annex.CopyFile where import Annex.Common -import Types.Remote import Utility.Metered import Utility.CopyFile import Utility.FileMode import Utility.Touch -import Types.Backend -import Annex.Verify +import Utility.Hash (IncrementalVerifier(..)) import Control.Concurrent import qualified Data.ByteString as S import Data.Time.Clock.POSIX --- Copies from src to dest, updating a meter. If the copy finishes --- successfully, calls a final check action, which must also succeed, or --- returns false. --- --- If either the remote or local repository wants to use hard links, --- the copier will do so (falling back to copying if a hard link cannot be --- made). --- --- When a hard link is created, returns Verified; the repo being linked --- from is implicitly trusted, so no expensive verification needs to be --- done. Also returns Verified if the key's content is verified while --- copying it. -type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification) - -- To avoid the overhead of trying copy-on-write every time, it's tried -- once and if it fails, is not tried again. newtype CopyCoWTried = CopyCoWTried (MVar Bool) @@ -62,14 +46,18 @@ docopycow = watchFileSize dest meterupdate $ copyCoW CopyTimeStamps src dest -{- Copys a file. Uses copy-on-write if it is supported. Otherwise, - - copies the file itself. If the destination already exists, - - an interruped copy will resume where it left off. +data CopyMethod = CopiedCoW | Copied + +{- Copies from src to dest, updating a meter. Preserves mode and mtime. + - Uses copy-on-write if it is supported. If the the destination already + - exists, an interruped copy will resume where it left off. - - - When copy-on-write is used, returns UnVerified, because the content of - - the file has not been verified to be correct. When the file has to be - - read to copy it, a hash is calulated at the same time. + - The IncrementalVerifier is updated with the content of the file as it's + - being copied. But it is not finalized at the end. - + - When copy-on-write is used, the IncrementalVerifier is not fed + - the content of the file, and verification using it will fail. + - - Note that, when the destination file already exists, it's read both - to start calculating the hash, and also to verify that its content is - the same as the start of the source file. It's possible that the @@ -77,13 +65,15 @@ - (eg when isStableKey is false), and doing this avoids getting a - corrupted file in such cases. -} -fileCopier :: CopyCoWTried -> FileCopier +fileCopier :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex CopyMethod #ifdef mingw32_HOST_OS -fileCopier _ src dest k meterupdate check verifyconfig = docopy +fileCopier _ src dest meterupdate iv = docopy #else -fileCopier copycowtried src dest k meterupdate check verifyconfig = +fileCopier copycowtried src dest meterupdate iv = ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate) - ( unVerified check + ( do + liftIO $ maybe noop unableIncremental iv + return CopiedCoW , docopy ) #endif @@ -91,16 +81,14 @@ dest' = toRawFilePath dest docopy = do - iv <- startVerifyKeyContentIncrementally verifyconfig k - -- The file might have had the write bit removed, -- so make sure we can write to it. void $ liftIO $ tryIO $ allowWrite dest' liftIO $ withBinaryFile dest ReadWriteMode $ \hdest -> withBinaryFile src ReadMode $ \hsrc -> do - sofar <- compareexisting iv hdest hsrc zeroBytesProcessed - docopy' iv hdest hsrc sofar + sofar <- compareexisting hdest hsrc zeroBytesProcessed + docopy' hdest hsrc sofar -- Copy src mode and mtime. mode <- liftIO $ fileMode <$> getFileStatus src @@ -108,19 +96,9 @@ liftIO $ setFileMode dest mode liftIO $ touch dest' mtime False - ifM check - ( case iv of - Just x -> ifM (liftIO $ finalizeIncremental x) - ( return (True, Verified) - , do - warning "verification of content failed" - return (False, UnVerified) - ) - Nothing -> return (True, UnVerified) - , return (False, UnVerified) - ) + return Copied - docopy' iv hdest hsrc sofar = do + docopy' hdest hsrc sofar = do s <- S.hGet hsrc defaultChunkSize if s == S.empty then return () @@ -129,12 +107,12 @@ S.hPut hdest s maybe noop (flip updateIncremental s) iv meterupdate sofar' - docopy' iv hdest hsrc sofar' + docopy' hdest hsrc sofar' -- Leaves hdest and hsrc seeked to wherever the two diverge, -- so typically hdest will be seeked to end, and hsrc to the same -- position. - compareexisting iv hdest hsrc sofar = do + compareexisting hdest hsrc sofar = do s <- S.hGet hdest defaultChunkSize if s == S.empty then return sofar @@ -145,7 +123,7 @@ maybe noop (flip updateIncremental s) iv let sofar' = addBytesProcessed sofar (S.length s) meterupdate sofar' - compareexisting iv hdest hsrc sofar' + compareexisting hdest hsrc sofar' else do seekbefore hdest s seekbefore hsrc s' diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -1,6 +1,6 @@ {- git-annex content ingestion - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,6 +9,7 @@ LockedDown(..), LockDownConfig(..), lockDown, + checkLockedDownWritePerms, ingestAdd, ingestAdd', ingest, @@ -51,8 +52,6 @@ import Annex.FileMatcher import qualified Utility.RawFilePath as R -import Control.Exception (IOException) - data LockedDown = LockedDown { lockDownConfig :: LockDownConfig , keySource :: KeySource @@ -63,7 +62,9 @@ { lockingFile :: Bool -- ^ write bit removed during lock down , hardlinkFileTmpDir :: Maybe RawFilePath - -- ^ hard link to temp directory + -- ^ hard link to temp directorya + , checkWritePerms :: Bool + -- ^ check that write perms are successfully removed } deriving (Show) @@ -78,16 +79,17 @@ - against some changes, like deletion or overwrite of the file, and - allows lsof checks to be done more efficiently when adding a lot of files. - - - Lockdown can fail if a file gets deleted, and Nothing will be returned. + - Lockdown can fail if a file gets deleted, or if it's unable to remove + - write permissions, and Nothing will be returned. -} -lockDown :: LockDownConfig -> FilePath -> Annex (Maybe LockedDown) +lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown) lockDown cfg file = either (\e -> warning (show e) >> return Nothing) (return . Just) =<< lockDown' cfg file -lockDown' :: LockDownConfig -> FilePath -> Annex (Either IOException LockedDown) -lockDown' cfg file = tryIO $ ifM crippledFileSystem +lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown) +lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem ( nohardlink , case hardlinkFileTmpDir cfg of Nothing -> nohardlink @@ -96,7 +98,9 @@ where file' = toRawFilePath file - nohardlink = withTSDelta $ liftIO . nohardlink' + nohardlink = do + setperms + withTSDelta $ liftIO . nohardlink' nohardlink' delta = do cache <- genInodeCache file' delta @@ -107,10 +111,9 @@ } withhardlink tmpdir = do - when (lockingFile cfg) $ - freezeContent file' + setperms withTSDelta $ \delta -> liftIO $ do - (tmpfile, h) <- openTempFile (fromRawFilePath tmpdir) $ + (tmpfile, h) <- openTmpFileIn (fromRawFilePath tmpdir) $ relatedTemplate $ "ingest-" ++ takeFileName file hClose h removeWhenExistsWith R.removeLink (toRawFilePath tmpfile) @@ -125,6 +128,20 @@ , contentLocation = toRawFilePath tmpfile , inodeCache = cache } + + setperms = when (lockingFile cfg) $ do + freezeContent file' + when (checkWritePerms cfg) $ + maybe noop giveup =<< checkLockedDownWritePerms file' file' + +checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe String) +checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case + Just False -> Just $ unwords + [ "Unable to remove all write permissions from" + , fromRawFilePath displayfile + , "-- perhaps it has an xattr or ACL set." + ] + _ -> Nothing {- Ingests a locked down file into the annex. Updates the work tree and - index. -} diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -275,18 +275,22 @@ liftIO $ createSymbolicLink f f2 liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2) (fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f) - -- Should be unable to write to the file, unless - -- running as root, but some crippled - -- filesystems ignore write bit removals. - liftIO $ ifM ((== 0) <$> getRealUserID) - ( return (False, []) - , do - r <- catchBoolIO $ do - writeFile f "2" - return True - if r - then return (True, ["Filesystem allows writing to files whose write bit is not set."]) - else return (False, []) + -- Should be unable to write to the file (unless + -- running as root). But some crippled + -- filesystems ignore write bit removals or ignore + -- permissions entirely. + ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f))) + ( return (True, ["Filesystem does not allow removing write bit from files."]) + , liftIO $ ifM ((== 0) <$> getRealUserID) + ( return (False, []) + , do + r <- catchBoolIO $ do + writeFile f "2" + return True + if r + then return (True, ["Filesystem allows writing to files whose write bit is not set."]) + else return (False, []) + ) ) #endif diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -72,11 +72,11 @@ - only changes to add the date fields. -} dateMetaData :: UTCTime -> MetaData -> MetaData dateMetaData mtime old = modMeta old $ - (SetMeta yearMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show y) + (SetMeta yearMetaField $ S.singleton $ toMetaValue $ encodeBS $ show y) `ComposeModMeta` - (SetMeta monthMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show m) + (SetMeta monthMetaField $ S.singleton $ toMetaValue $ encodeBS $ show m) `ComposeModMeta` - (SetMeta dayMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show d) + (SetMeta dayMetaField $ S.singleton $ toMetaValue $ encodeBS $ show d) where (y, m, d) = toGregorian $ utctDay mtime diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -16,7 +16,8 @@ noUmask, freezeContent, freezeContent', - isContentWritePermOk, + checkContentWritePerm, + checkContentWritePerm', thawContent, thawContent', createContentDir, @@ -131,6 +132,12 @@ - necessary to let other users in the group lock the file. But, in a - shared repository, the current user may not be able to change a file - owned by another user, so failure to set this mode is ignored. + - + - Note that, on Linux, xattrs can sometimes prevent removing + - certain permissions from a file with chmod. (Maybe some ACLs too?) + - In such a case, this will return with the file still having some mode + - it should not normally have. checkContentWritePerm can detect when + - that happens with write permissions. -} freezeContent :: RawFilePath -> Annex () freezeContent file = unlessM crippledFileSystem $ @@ -149,19 +156,36 @@ removeModes writeModes . addModes [ownerReadMode] -isContentWritePermOk :: RawFilePath -> Annex Bool -isContentWritePermOk file = ifM crippledFileSystem - ( return True - , withShared go +{- Checks if the write permissions are as freezeContent should set them. + - + - When the repository is shared, the user may not be able to change + - permissions of a file owned by another user. So if the permissions seem + - wrong, but the repository is shared, returns Nothing. If the permissions + - are wrong otherwise, returns Just False. + -} +checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool) +checkContentWritePerm file = ifM crippledFileSystem + ( return (Just True) + , withShared (\sr -> liftIO (checkContentWritePerm' sr file)) ) + +checkContentWritePerm' :: SharedRepository -> RawFilePath -> IO (Maybe Bool) +checkContentWritePerm' sr file = case sr of + GroupShared -> want sharedret + (includemodes [ownerWriteMode, groupWriteMode]) + AllShared -> want sharedret (includemodes writeModes) + _ -> want Just (excludemodes writeModes) where - go GroupShared = want [ownerWriteMode, groupWriteMode] - go AllShared = want writeModes - go _ = return True - want wantmode = - liftIO (catchMaybeIO $ fileMode <$> R.getFileStatus file) >>= return . \case - Nothing -> True - Just havemode -> havemode == combineModes (havemode:wantmode) + want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) + >>= return . \case + Just havemode -> mk (f havemode) + Nothing -> mk True + + includemodes l havemode = havemode == combineModes (havemode:l) + excludemodes l havemode = all (\m -> intersectFileModes m havemode == nullFileMode) l + + sharedret True = Just True + sharedret False = Nothing {- Allows writing to an annexed file that freezeContent was called on - before. -} diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -78,10 +78,11 @@ Just StallDetectionDisabled -> go Nothing Just sd -> runTransferrer sd r key f d Download witness where - go sd = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest -> + go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f $ \dest -> download' (Remote.uuid r) key f sd d (go' dest) witness go' dest p = verifiedAction $ - Remote.retrieveKeyFile r key f (fromRawFilePath dest) p + Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc + vc = Remote.RemoteVerify r -- Download, not supporting canceling detected stalls. download' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -110,7 +110,7 @@ {- Only sets the configkey in the Repo; does not change .git/config -} setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID r u = do - let s = encodeBS' $ show configkeyUUID ++ "=" ++ fromUUID u + let s = encodeBS $ show configkeyUUID ++ "=" ++ fromUUID u Git.Config.store s Git.Config.ConfigList r -- Dummy uuid for the whole web. Do not alter. diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -34,6 +34,7 @@ import Annex.Common import qualified Annex import qualified Utility.Url as U +import Utility.Hash (IncrementalVerifier) import Utility.IPAddress #ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted @@ -172,15 +173,15 @@ Right r -> return r Left err -> warning err >> return False -download :: MeterUpdate -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool -download meterupdate url file uo = - liftIO (U.download meterupdate url file uo) >>= \case +download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool +download meterupdate iv url file uo = + liftIO (U.download meterupdate iv url file uo) >>= \case Right () -> return True Left err -> warning err >> return False -download' :: MeterUpdate -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ()) -download' meterupdate url file uo = - liftIO (U.download meterupdate url file uo) +download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ()) +download' meterupdate iv url file uo = + liftIO (U.download meterupdate iv url file uo) exists :: U.URLString -> U.UrlOptions -> Annex Bool exists url uo = liftIO (U.exists url uo) >>= \case diff --git a/Annex/VectorClock.hs b/Annex/VectorClock.hs --- a/Annex/VectorClock.hs +++ b/Annex/VectorClock.hs @@ -1,9 +1,11 @@ {- git-annex vector clocks - - - We don't have a way yet to keep true distributed vector clocks. - - The next best thing is a timestamp. + - These are basically a timestamp. However, when logging a new + - value, if the old value has a vector clock that is the same or greater + - than the current vector clock, the old vector clock is incremented. + - This way, clock skew does not cause confusion. - - - Copyright 2017-2020 Joey Hess + - Copyright 2017-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,10 +23,12 @@ import Data.ByteString.Builder import qualified Data.Attoparsec.ByteString.Lazy as A -currentVectorClock :: Annex VectorClock +currentVectorClock :: Annex CandidateVectorClock currentVectorClock = liftIO =<< Annex.getState Annex.getvectorclock --- Runs the action and uses the same vector clock throughout. +-- Runs the action and uses the same vector clock throughout, +-- except when it's necessary to use a newer one due to a past value having +-- a newer vector clock. -- -- When the action modifies several files in the git-annex branch, -- this can cause less space to be used, since the same vector clock @@ -51,6 +55,19 @@ use vc = Annex.changeState $ \s -> s { Annex.getvectorclock = vc } + +-- Convert a candidate vector clock in to the final one to use, +-- advancing it if necessary when necessary to get ahead of a previously +-- used vector clock. +advanceVectorClock :: CandidateVectorClock -> [VectorClock] -> VectorClock +advanceVectorClock (CandidateVectorClock c) [] = VectorClock c +advanceVectorClock (CandidateVectorClock c) prevs + | prev >= VectorClock c = case prev of + VectorClock v -> VectorClock (v + 1) + Unknown -> VectorClock c + | otherwise = VectorClock c + where + prev = maximum prevs formatVectorClock :: VectorClock -> String formatVectorClock Unknown = "0" diff --git a/Annex/VectorClock/Utility.hs b/Annex/VectorClock/Utility.hs --- a/Annex/VectorClock/Utility.hs +++ b/Annex/VectorClock/Utility.hs @@ -13,11 +13,11 @@ import Utility.Env import Utility.TimeStamp -startVectorClock :: IO (IO VectorClock) +startVectorClock :: IO (IO CandidateVectorClock) startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK" where go Nothing = timebased go (Just s) = case parsePOSIXTime s of - Just t -> return (pure (VectorClock t)) + Just t -> return (pure (CandidateVectorClock t)) Nothing -> timebased - timebased = return (VectorClock <$> getPOSIXTime) + timebased = return (CandidateVectorClock <$> getPOSIXTime) diff --git a/Annex/Verify.hs b/Annex/Verify.hs --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -5,8 +5,9 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Verify ( - VerifyConfig(..), shouldVerify, verifyKeyContentPostRetrieval, verifyKeyContent, @@ -15,21 +16,29 @@ warnUnverifiableInsecure, isVerifiable, startVerifyKeyContentIncrementally, + finishVerifyKeyContentIncrementally, IncrementalVerifier(..), + tailVerify, ) where import Annex.Common import qualified Annex import qualified Types.Remote +import Types.Remote (VerifyConfigA(..)) import qualified Types.Backend -import Types.Backend (IncrementalVerifier(..)) import qualified Backend import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) +import Utility.Hash (IncrementalVerifier(..)) import Annex.WorkerPool import Types.WorkerPool import Types.Key -data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify +import Control.Concurrent.STM +import qualified Data.ByteString as S +#if WITH_INOTIFY +import qualified System.INotify as INotify +import qualified System.FilePath.ByteString as P +#endif shouldVerify :: VerifyConfig -> Annex Bool shouldVerify AlwaysVerify = return True @@ -71,23 +80,71 @@ , return True ) (_, MustVerify) -> verify + (_, IncompleteVerify _) -> ifM (shouldVerify v) + ( verify + , return True + ) where - verify = enteringStage VerifyStage $ verifyKeyContent k f + verify = enteringStage VerifyStage $ + case verification of + IncompleteVerify iv -> resumeVerifyKeyContent k f iv + _ -> verifyKeyContent k f verifyKeyContent :: Key -> RawFilePath -> Annex Bool -verifyKeyContent k f = verifysize <&&> verifycontent - where - 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 +verifyKeyContent k f = verifyKeySize k f <&&> verifyKeyContent' k f + +verifyKeyContent' :: Key -> RawFilePath -> Annex Bool +verifyKeyContent' k f = + 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 +resumeVerifyKeyContent :: Key -> RawFilePath -> IncrementalVerifier -> Annex Bool +resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case + Nothing -> fallback + Just endpos -> do + fsz <- liftIO $ catchDefaultIO 0 $ getFileSize f + if fsz < endpos + then fallback + else case fromKey keySize k of + Just size | fsz /= size -> return False + _ -> go fsz endpos >>= \case + Just v -> return v + Nothing -> fallback + where + fallback = verifyKeyContent k f + + go fsz endpos + | fsz == endpos = + liftIO $ catchDefaultIO (Just False) $ + finalizeIncremental iv + | otherwise = do + showAction (descVerify iv) + liftIO $ catchDefaultIO (Just False) $ + withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do + hSeek h AbsoluteSeek endpos + feedincremental h + finalizeIncremental iv + + feedincremental h = do + b <- S.hGetSome h chunk + if S.null b + then return () + else do + updateIncremental iv b + feedincremental h + + chunk = 65536 + +verifyKeySize :: Key -> RawFilePath -> Annex Bool +verifyKeySize k f = case fromKey keySize k of + Just size -> do + size' <- liftIO $ catchDefaultIO 0 $ getFileSize f + return (size' == size) + Nothing -> return True + warnUnverifiableInsecure :: Key -> Annex () warnUnverifiableInsecure k = warning $ unwords [ "Getting " ++ kv ++ " keys with this remote is not secure;" @@ -112,3 +169,144 @@ Nothing -> return Nothing , return Nothing ) + +finishVerifyKeyContentIncrementally :: Maybe IncrementalVerifier -> Annex (Bool, Verification) +finishVerifyKeyContentIncrementally Nothing = + return (True, UnVerified) +finishVerifyKeyContentIncrementally (Just iv) = + liftIO (finalizeIncremental iv) >>= \case + Just True -> return (True, Verified) + Just False -> do + warning "verification of content failed" + return (False, UnVerified) + -- Incremental verification was not able to be done. + Nothing -> return (True, UnVerified) + +-- | Reads the file as it grows, and feeds it to the incremental verifier. +-- +-- The TMVar must start out empty, and be filled once whatever is +-- writing to the file finishes. Once the writer finishes, this returns +-- quickly. It may not feed the entire content of the file to the +-- incremental verifier. +-- +-- The file does not need to exist yet when this is called. It will wait +-- for the file to appear before opening it and starting verification. +-- +-- This is not supported for all OSs, and on OS's where it is not +-- supported, verification will not happen. +-- +-- The writer probably needs to be another process. If the file is being +-- written directly by git-annex, the haskell RTS will prevent opening it +-- for read at the same time, and verification will not happen. +-- +-- Note that there are situations where the file may fail to verify despite +-- having the correct content. For example, when the file is written out +-- of order, or gets replaced part way through. To deal with such cases, +-- when verification fails, it should not be treated as if the file's +-- content is known to be incorrect, but instead as an indication that the +-- file should be verified again, once it's done being written to. +-- +-- (It is also possible, in theory, for a file to verify despite having +-- incorrect content. For that to happen, the file would need to have +-- the right content when this checks it, but then the content gets +-- changed later by whatever is writing to the file.) +-- +-- This should be fairly efficient, reading from the disk cache, +-- as long as the writer does not get very far ahead of it. However, +-- there are situations where it would be much less expensive to verify +-- chunks as they are being written. For example, when resuming with +-- a lot of content in the file, all that content needs to be read, +-- and if the disk is slow, the reader may never catch up to the writer, +-- and the disk cache may never speed up reads. So this should only be +-- used when there's not a better way to incrementally verify. +tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO () +#if WITH_INOTIFY +tailVerify iv f finished = + tryNonAsync go >>= \case + Right r -> return r + Left _ -> unableIncremental iv + where + -- Watch the directory containing the file, and wait for + -- the file to be modified. It's possible that the file already + -- exists before the downloader starts, but it replaces it instead + -- of resuming, and waiting for modification deals with such + -- situations. + inotifydirchange i cont = + INotify.addWatch i [INotify.Modify] dir $ \case + -- Ignore changes to other files in the directory. + INotify.Modified { INotify.maybeFilePath = fn } + | fn == Just basef -> cont + _ -> noop + where + (dir, basef) = P.splitFileName f + + inotifyfilechange i = INotify.addWatch i [INotify.Modify] f . const + + go = INotify.withINotify $ \i -> do + modified <- newEmptyTMVarIO + let signalmodified = atomically $ void $ tryPutTMVar modified () + wd <- inotifydirchange i signalmodified + let cleanup = void . tryNonAsync . INotify.removeWatch + let stop w = do + cleanup w + unableIncremental iv + waitopen modified >>= \case + Nothing -> stop wd + Just h -> do + cleanup wd + wf <- inotifyfilechange i signalmodified + tryNonAsync (follow h modified) >>= \case + Left _ -> stop wf + Right () -> cleanup wf + hClose h + + waitopen modified = do + v <- atomically $ + (Just <$> takeTMVar modified) + `orElse` + ((const Nothing) <$> takeTMVar finished) + case v of + Just () -> do + r <- tryNonAsync $ + tryWhenExists (openBinaryFile (fromRawFilePath f) ReadMode) >>= \case + Just h -> return (Just h) + -- File does not exist, must have been + -- deleted. Wait for next modification + -- and try again. + Nothing -> waitopen modified + case r of + Right r' -> return r' + -- Permission error prevents + -- reading, or this same process + -- is writing to the file, + -- and it cannot be read at the + -- same time. + Left _ -> return Nothing + -- finished without the file being modified + Nothing -> return Nothing + + follow h modified = do + b <- S.hGetNonBlocking h chunk + if S.null b + then do + -- We've caught up to the writer. + -- Wait for the file to get modified again, + -- or until we're told it is done being + -- written. + cont <- atomically $ + (const (follow h modified) + <$> takeTMVar modified) + `orElse` + (const (return ()) + <$> takeTMVar finished) + cont + else do + updateIncremental iv b + atomically (tryTakeTMVar finished) >>= \case + Nothing -> follow h modified + Just () -> return () + + chunk = 65536 +#else +tailVerify iv _ _ = unableIncremental iv +#endif diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs --- a/Annex/View/ViewedFile.hs +++ b/Annex/View/ViewedFile.hs @@ -36,7 +36,7 @@ - So, from dir/subdir/file.foo, generate file_%dir%subdir%.foo -} viewedFileFromReference :: MkViewedFile -viewedFileFromReference f = concat +viewedFileFromReference f = concat $ [ escape (fromRawFilePath base) , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%" , escape $ fromRawFilePath $ S.concat extensions @@ -44,7 +44,13 @@ where (path, basefile) = splitFileName f dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) - (base, extensions) = splitShortExtensions (toRawFilePath basefile) + (base, extensions) = splitShortExtensions (toRawFilePath basefile') + + {- On Windows, if the filename looked like "dir/c:foo" then + - basefile would look like it contains a drive letter, which will + - not work. There cannot really be a filename like that, probably, + - but it prevents the test suite failing. -} + (_basedrive, basefile') = splitDrive basefile {- To avoid collisions with filenames or directories that contain - '%', and to allow the original directories to be extracted diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -1,6 +1,6 @@ {- youtube-dl integration for git-annex - - - Copyright 2017-2020 Joey Hess + - Copyright 2017-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -68,7 +68,7 @@ youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath)) youtubeDl' url workdir p uo - | supportedScheme uo url = ifM (liftIO $ inSearchPath "youtube-dl") + | supportedScheme uo url = ifM (liftIO . inSearchPath =<< youtubeDlCommand) ( runcmd >>= \case Right True -> workdirfiles >>= \case (f:[]) -> return (Right (Just f)) @@ -88,6 +88,7 @@ runcmd = youtubeDlMaxSize workdir >>= \case Left msg -> return (Left msg) Right maxsize -> do + cmd <- youtubeDlCommand opts <- youtubeDlOpts (dlopts ++ maxsize) oh <- mkOutputHandlerQuiet -- The size is unknown to start. Once youtube-dl @@ -97,7 +98,7 @@ let unknownsize = Nothing :: Maybe FileSize ok <- metered (Just p) unknownsize $ \meter meterupdate -> liftIO $ commandMeter' - parseYoutubeDlProgress oh (Just meter) meterupdate "youtube-dl" opts + parseYoutubeDlProgress oh (Just meter) meterupdate cmd opts (\pr -> pr { cwd = Just workdir }) return (Right ok) dlopts = @@ -181,7 +182,8 @@ youtubeDlCheck' url uo | supportedScheme uo url = catchMsgIO $ htmlOnly url False $ do opts <- youtubeDlOpts [ Param url, Param "--simulate" ] - liftIO $ snd <$> processTranscript "youtube-dl" (toCommand opts) Nothing + cmd <- youtubeDlCommand + liftIO $ snd <$> processTranscript cmd (toCommand opts) Nothing | otherwise = return (Right False) -- Ask youtube-dl for the filename of media in an url. @@ -218,7 +220,8 @@ , Param "--no-warnings" , Param "--no-playlist" ] - let p = (proc "youtube-dl" (toCommand opts)) + cmd <- youtubeDlCommand + let p = (proc cmd (toCommand opts)) { std_out = CreatePipe , std_err = CreatePipe } @@ -244,6 +247,10 @@ youtubeDlOpts addopts = do opts <- map Param . annexYoutubeDlOptions <$> Annex.getGitConfig return (opts ++ addopts) + +youtubeDlCommand :: Annex String +youtubeDlCommand = fromMaybe "yooutube-dl" . annexYoutubeDlCommand + <$> Annex.getGitConfig supportedScheme :: UrlOptions -> URLString -> Bool supportedScheme uo url = case parseURIRelaxed url of diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -265,6 +265,7 @@ let lockdownconfig = LockDownConfig { lockingFile = False , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) + , checkWritePerms = True } (postponed, toadd) <- partitionEithers <$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess @@ -310,6 +311,7 @@ let cfg = LockDownConfig { lockingFile = False , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) + , checkWritePerms = True } if M.null m then forM toadd (addannexed' cfg) diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -118,6 +118,6 @@ n = '/' : Git.fromRef Annex.Branch.name fileToBranch :: FilePath -> Git.Ref -fileToBranch f = Git.Ref $ encodeBS' $ "refs" base +fileToBranch f = Git.Ref $ encodeBS $ "refs" base where base = Prelude.last $ split "/refs/" f diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -321,7 +321,7 @@ addLink file link mk = do debug ["add symlink", file] liftAnnex $ do - v <- catObjectDetails $ Ref $ encodeBS' $ ':':file + v <- catObjectDetails $ Ref $ encodeBS $ ':':file case v of Just (currlink, sha, _type) | L.fromStrict link == currlink -> diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -326,8 +326,8 @@ liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do let infof = tmpdir "info" let sigf = infof ++ ".sig" - ifM (isRight <$> Url.download nullMeterUpdate distributionInfoUrl infof uo - <&&> (isRight <$> Url.download nullMeterUpdate distributionInfoSigUrl sigf uo) + ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo + <&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo) <&&> verifyDistributionSig gpgcmd sigf) ( parseInfoFile <$> readFileStrict infof , return Nothing diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -102,7 +102,7 @@ - there's not. Special remotes don't normally - have that, and don't use it. Temporarily add - it if it's missing. -} - let remotefetch = Git.ConfigKey $ encodeBS' $ + let remotefetch = Git.ConfigKey $ encodeBS $ "remote." ++ T.unpack (repoName oldc) ++ ".fetch" needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch) when needfetch $ diff --git a/Backend/External.hs b/Backend/External.hs --- a/Backend/External.hs +++ b/Backend/External.hs @@ -239,7 +239,7 @@ warning msg externalBackendProgram :: ExternalBackendName -> String -externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS' bname +externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname -- Runs an action with an ExternalState, starting a new external backend -- process if necessary. It is returned to the pool once the action diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -28,7 +28,6 @@ import qualified Data.ByteString.Lazy as L import Control.DeepSeq import Control.Exception (evaluate) -import Data.IORef data Hash = MD5Hash @@ -124,7 +123,7 @@ exists <- liftIO $ R.doesPathExist file case (exists, fast) of (True, False) -> do - showAction "checksum" + showAction descChecksum sameCheckSum key <$> hashFile hash file nullMeterUpdate _ -> return True @@ -221,7 +220,7 @@ hasher (Blake2spHash hashsize) = blake2spHasher hashsize mkHasher :: HashAlgorithm h => (L.ByteString -> Digest h) -> Context h -> Hasher -mkHasher h c = (show . h, mkIncrementalVerifier c) +mkHasher h c = (show . h, mkIncrementalVerifier c descChecksum . sameCheckSum) sha2Hasher :: HashSize -> Hasher sha2Hasher (HashSize hashsize) @@ -278,16 +277,8 @@ md5Hasher :: Hasher md5Hasher = mkHasher md5 md5_context -mkIncrementalVerifier :: HashAlgorithm h => Context h -> Key -> IO IncrementalVerifier -mkIncrementalVerifier ctx key = do - v <- newIORef ctx - return $ IncrementalVerifier - { updateIncremental = modifyIORef' v . flip hashUpdate - , finalizeIncremental = do - ctx' <- readIORef v - let digest = hashFinalize ctx' - return $ sameCheckSum key (show digest) - } +descChecksum :: String +descChecksum = "checksum" {- A varient of the SHA256E backend, for testing that needs special keys - that cannot collide with legitimate keys in the repository. diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -28,10 +28,10 @@ genKeyName :: String -> S.ByteString genKeyName s -- Avoid making keys longer than the length of a SHA256 checksum. - | bytelen > sha256len = encodeBS' $ + | bytelen > sha256len = encodeBS $ truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ show (md5 bl) - | otherwise = encodeBS' s' + | otherwise = encodeBS s' where s' = preSanitizeKeyName s bl = encodeBL s @@ -59,8 +59,11 @@ es = filter (not . S.null) $ reverse $ take 2 $ filter (S.all validInExtension) $ takeWhile shortenough $ - reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f) + reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f') shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen + -- Avoid treating a file ".foo" as having its whole name as an + -- extension. + f' = S.dropWhile (== fromIntegral (ord '.')) (P.takeFileName f) validInExtension :: Word8 -> Bool validInExtension c diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -25,6 +25,7 @@ , testCp "cp_p" "-p" , testCp "cp_preserve_timestamps" "--preserve=timestamps" , testCpReflinkAuto + , testCpNoPreserveXattr , TestCase "xargs -0" $ testCmd "xargs_0" "xargs -0 /dev/null" , TestCase "curl" $ testCmd "curl" "curl --version >/dev/null" @@ -61,6 +62,11 @@ #endif where k = "cp_reflink_supported" + +testCpNoPreserveXattr :: TestCase +testCpNoPreserveXattr = testCp + "cp_no_preserve_xattr_supported" + "--no-preserve=xattr" getUpgradeLocation :: Test getUpgradeLocation = do diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,39 @@ +git-annex (8.20210903) upstream; urgency=medium + + * Deal with clock skew, both forwards and backwards, when logging + information to the git-annex branch. + * GIT_ANNEX_VECTOR_CLOCK can now be set to a fixed value (eg 1) + rather than needing to be advanced each time a new change is made. + * Misuse of GIT_ANNEX_VECTOR_CLOCK will no longer confuse git-annex. + * add: When adding a dotfile, avoid treating its name as an extension. + * rsync special remote: Stop displaying rsync progress, and use + git-annex's own progress display. + * Many special remotes now checksum content while it is being retrieved, + instead of in a separate pass at the end. This is supported for all + special remotes on Linux (except for bittorrent), and for many + on other OS's (except for adb, external, gcrypt, hook, and rsync). + * unused: Skip the refs/annex/last-index ref that git-annex recently + started creating. + * Fix test suite failure on Windows. + * New --batch-keys option added to these commands: + get, drop, move, copy, whereis + * Added annex.youtube-dl-command config. This can be used to run some + forks of youtube-dl. + * Run cp -a with --no-preserve=xattr, to avoid problems with copied + xattrs, including them breaking permissions setting on some NFS + servers. + * add, import: Detect when xattrs or perhaps ACLs prevent removing + write permissions from an annexed file, and fail with an informative + message. + * Fix support for readonly git remotes. + (Reversion in version 8.20210621) + * When downloading urls fail, explain which urls failed for which + reasons. + * web: Avoid displaying a warning when downloading one url failed + but another url later succeeded. + + -- Joey Hess Fri, 03 Sep 2021 12:00:46 -0400 + git-annex (8.20210803) upstream; urgency=medium * whereused: New command, finds what files use a key, or where a key diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -1,6 +1,6 @@ {- git-annex batch commands - - - Copyright 2015-2020 Joey Hess + - Copyright 2015-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,23 +24,43 @@ data BatchMode = Batch BatchFormat | NoBatch -data BatchFormat = BatchLine | BatchNull +data BatchFormat = BatchFormat BatchSeparator BatchKeys -parseBatchOption :: Parser BatchMode -parseBatchOption = go +data BatchSeparator = BatchLine | BatchNull + +newtype BatchKeys = BatchKeys Bool + +parseBatchOption :: Bool -> Parser BatchMode +parseBatchOption supportbatchkeysoption = go <$> switch ( long "batch" - <> help "enable batch mode" + <> help batchhelp ) - <*> switch + <*> batchkeysswitch + <*> flag BatchLine BatchNull ( short 'z' <> help "null delimited batch input" ) where - go True False = Batch BatchLine - go True True = Batch BatchNull - go False _ = NoBatch + go True False batchseparator = + Batch (BatchFormat batchseparator (BatchKeys False)) + go _ True batchseparator = + Batch (BatchFormat batchseparator (BatchKeys True)) + go _ _ _ = NoBatch + batchhelp = "enable batch mode" ++ + if supportbatchkeysoption + then ", with files input" + else "" + batchkeyshelp = "enable batch mode, with keys input" + + batchkeysswitch + | supportbatchkeysoption = switch + ( long "batch-keys" + <> help batchkeyshelp + ) + | otherwise = pure False + -- A batchable command can run in batch mode, or not. -- In batch mode, one line at a time is read, parsed, and a reply output to -- stdout. In non batch mode, the command's parameters are parsed and @@ -52,7 +72,7 @@ where batchparser = (,,) <$> parser - <*> parseBatchOption + <*> parseBatchOption False <*> cmdParams paramdesc batchseeker (opts, NoBatch, params) = @@ -68,7 +88,7 @@ -- mode, exit on bad input. batchBadInput :: BatchMode -> Annex () batchBadInput NoBatch = liftIO exitFailure -batchBadInput (Batch _) = liftIO $ putStrLn "" +batchBadInput _ = liftIO $ putStrLn "" -- Reads lines of batch mode input, runs a parser, and passes the result -- to the action. @@ -87,12 +107,12 @@ parseerr s = giveup $ "Batch input parse failure: " ++ s batchLines :: BatchFormat -> Annex [String] -batchLines fmt = do +batchLines (BatchFormat sep _) = do checkBatchConcurrency enableInteractiveBranchAccess liftIO $ splitter <$> getContents where - splitter = case fmt of + splitter = case sep of BatchLine -> lines BatchNull -> splitc '\0' @@ -116,37 +136,76 @@ batchCommandStart a = a >>= \case Just v -> return (Just v) Nothing -> do - batchBadInput (Batch BatchLine) + batchBadInput (Batch (BatchFormat BatchLine (BatchKeys False))) return Nothing -- Reads lines of batch input and passes the filepaths to a CommandStart -- to handle them. -- --- Absolute filepaths are converted to relative, because in non-batch --- mode, that is done when CmdLine.Seek uses git ls-files. --- -- File matching options are checked, and non-matching files skipped. -batchFilesMatching :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex () -batchFilesMatching fmt a = do +batchFiles :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex () +batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of + Right f -> a (si, f) + Left _k -> return Nothing + +batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key RawFilePath) -> CommandStart) -> Annex () +batchFilesKeys fmt a = do matcher <- getMatcher - go $ \si f -> - let f' = toRawFilePath f - in ifM (matcher $ MatchingFile $ FileInfo f' f' Nothing) - ( a (si, f') - , return Nothing - ) + go $ \si v -> case v of + Right f -> + let f' = toRawFilePath f + in ifM (matcher $ MatchingFile $ FileInfo f' f' Nothing) + ( a (si, Right f') + , return Nothing + ) + Left k -> a (si, Left k) where - go a' = batchInput fmt - (Right . fromRawFilePath <$$> liftIO . relPathCwdToFile . toRawFilePath) - (batchCommandAction . uncurry a') + go a' = batchInput fmt parser (batchCommandAction . uncurry a') + parser = case fmt of + -- Absolute filepaths are converted to relative, + -- because in non-batch mode, that is done when + -- CmdLine.Seek uses git ls-files. + BatchFormat _ (BatchKeys False) -> + Right . Right . fromRawFilePath + <$$> liftIO . relPathCwdToFile . toRawFilePath + BatchFormat _ (BatchKeys True) -> \i -> + pure $ case deserializeKey i of + Just k -> Right (Left k) + Nothing -> Left "not a valid key" -batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex () -batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ \(si, bf) -> - flip whenAnnexed bf $ \f k -> - case checkContentPresent seeker of - Just v -> do - present <- inAnnex k - if present == v - then startAction seeker si f k - else return Nothing - Nothing -> startAction seeker si f k +batchAnnexedFiles :: BatchFormat -> AnnexedFileSeeker -> Annex () +batchAnnexedFiles fmt seeker = batchAnnexed fmt seeker (const (return Nothing)) + +-- Reads lines of batch input and passes filepaths to the AnnexedFileSeeker +-- to handle them. Or, with --batch-keys, passes keys to the keyaction. +-- +-- Matching options are checked, and non-matching items skipped. +batchAnnexed :: BatchFormat -> AnnexedFileSeeker -> ((SeekInput, Key, ActionItem) -> CommandStart) -> Annex () +batchAnnexed fmt seeker keyaction = do + matcher <- getMatcher + batchFilesKeys fmt $ \(si, v) -> + case v of + Right bf -> flip whenAnnexed bf $ \f k -> + checkpresent k $ + startAction seeker si f k + Left k -> ifM (matcher (MatchingInfo (mkinfo k))) + ( checkpresent k $ + keyaction (si, k, mkActionItem k) + , return Nothing) + where + checkpresent k cont = case checkContentPresent seeker of + Just v -> do + present <- inAnnex k + if present == v + then cont + else return Nothing + Nothing -> cont + + mkinfo k = ProvidedInfo + { providedFilePath = Nothing + , providedKey = Just k + , providedFileSize = Nothing + , providedMimeType = Nothing + , providedMimeEncoding = Nothing + , providedLinkType = Nothing + } diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -79,7 +79,7 @@ -- Also set in git config so it will be passed on to any -- git-annex child processes. , setAnnexState $ Annex.addGitConfigOverride $ - decodeBS' $ debugconfig <> "=" <> boolConfig' v + decodeBS $ debugconfig <> "=" <> boolConfig' v ] setdebugfilter v = mconcat @@ -88,7 +88,7 @@ -- Also set in git config so it will be passed on to any -- git-annex child processes. , setAnnexState $ Annex.addGitConfigOverride $ - decodeBS' (debugfilterconfig <> "=") ++ v + decodeBS (debugfilterconfig <> "=") ++ v ] (ConfigKey debugconfig) = annexConfig "debug" diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -50,7 +50,7 @@ optParser :: CmdParamsDesc -> Parser AddOptions optParser desc = AddOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False <*> switch ( long "update" <> short 'u' @@ -95,7 +95,7 @@ Batch fmt | updateOnly o -> giveup "--update --batch is not supported" - | otherwise -> batchFilesMatching fmt gofile + | otherwise -> batchFiles fmt gofile NoBatch -> do -- Avoid git ls-files complaining about files that -- are not known to git yet, since this will add @@ -188,6 +188,7 @@ let cfg = LockDownConfig { lockingFile = lockingfile , hardlinkFileTmpDir = Just tmpdir + , checkWritePerms = True } ld <- lockDown cfg (fromRawFilePath file) let sizer = keySource <$> ld diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -76,7 +76,7 @@ <> help "add a suffix to the filename" )) <*> parseDownloadOptions True - <*> parseBatchOption + <*> parseBatchOption False <*> switch ( long "with-files" <> help "parse batch mode lines of the form \"$url $file\"" @@ -201,7 +201,8 @@ -- should use to download it. setTempUrl urlkey loguri let downloader = \dest p -> - fst <$> Remote.verifiedAction (Remote.retrieveKeyFile r urlkey af dest p) + fst <$> Remote.verifiedAction + (Remote.retrieveKeyFile r urlkey af dest p (RemoteVerify r)) ret <- downloadWith canadd addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file removeTempUrl urlkey return ret @@ -313,7 +314,7 @@ go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file)) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing - downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f + downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp))) ( tryyoutubedl tmp diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -26,7 +26,7 @@ optParser :: CmdParamsDesc -> Parser CheckPresentKeyOptions optParser desc = CheckPresentKeyOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False seek :: CheckPresentKeyOptions -> CommandSeek seek o = case batchOption o of diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -55,23 +55,23 @@ seek :: Action -> CommandSeek seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $ - startingUsualMessages (decodeBS' name) ai si $ do + startingUsualMessages (decodeBS name) ai si $ do setGlobalConfig ck val when (needLocalUpdate ck) $ setConfig ck (fromConfigValue val) next $ return True where ai = ActionItemOther (Just (fromConfigValue val)) - si = SeekInput [decodeBS' name] + si = SeekInput [decodeBS name] seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $ - startingUsualMessages (decodeBS' name) ai si $ do + startingUsualMessages (decodeBS name) ai si $ do unsetGlobalConfig ck when (needLocalUpdate ck) $ unsetConfig ck next $ return True where ai = ActionItemOther (Just "unset") - si = SeekInput [decodeBS' name] + si = SeekInput [decodeBS name] seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $ startingCustomOutput ai $ do getGlobalConfig ck >>= \case diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -33,7 +33,7 @@ <*> parseFromToHereOptions <*> optional (parseKeyOptions <|> parseFailedTransfersOption) <*> parseAutoOption - <*> parseBatchOption + <*> parseBatchOption True instance DeferredParseClass CopyOptions where finishParse v = CopyOptions @@ -48,10 +48,10 @@ case batchOption o of NoBatch -> withKeyOptions (keyOptions o) (autoMode o) seeker - (commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) + (commandAction . keyaction) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (copyFiles o) - Batch fmt -> batchAnnexedFilesMatching fmt seeker + Batch fmt -> batchAnnexed fmt seeker keyaction where ww = WarnUnmatchLsFiles @@ -63,6 +63,7 @@ Left ToHere -> Just False , usesLocationLog = True } + keyaction = Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -89,7 +89,7 @@ check rOldFile rOldMode (\r f -> r { rOldFile = f }) req >>= check rNewFile rNewMode (\r f -> r { rNewFile = f }) where - check getfile getmode setfile r = case readTreeItemType (encodeBS' (getmode r)) of + check getfile getmode setfile r = case readTreeItemType (encodeBS (getmode r)) of Just TreeSymlink -> do v <- getAnnexLinkTarget' f False maybe (return r) repoint (parseLinkTargetOrPointer =<< v) diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -41,7 +41,7 @@ <*> optional parseDropFromOption <*> parseAutoOption <*> optional parseKeyOptions - <*> parseBatchOption + <*> parseBatchOption True parseDropFromOption :: Parser (DeferredParse Remote) parseDropFromOption = parseRemoteOption <$> strOption @@ -67,11 +67,11 @@ , usesLocationLog = True } case batchOption o of - Batch fmt -> batchAnnexedFilesMatching fmt seeker NoBatch -> withKeyOptions (keyOptions o) (autoMode o) seeker (commandAction . startKeys o from) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (dropFiles o) + Batch fmt -> batchAnnexed fmt seeker (startKeys o from) where ww = WarnUnmatchLsFiles diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -27,7 +27,7 @@ optParser :: CmdParamsDesc -> Parser DropKeyOptions optParser desc = DropKeyOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False seek :: DropKeyOptions -> CommandSeek seek o = do diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -39,7 +39,7 @@ <$> cmdParams desc <*> optional parseFormatOption <*> optional parseBranchKeysOption - <*> parseBatchOption + <*> parseBatchOption False parseFormatOption :: Parser Utility.Format.Format parseFormatOption = @@ -69,7 +69,7 @@ (commandAction . startKeys o) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (findThese o) - Batch fmt -> batchAnnexedFilesMatching fmt seeker + Batch fmt -> batchAnnexedFiles fmt seeker where ww = WarnUnmatchLsFiles diff --git a/Command/FindRef.hs b/Command/FindRef.hs --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -22,6 +22,6 @@ where o' = o { Find.keyOptions = Just $ WantBranchKeys $ - map (Git.Ref . encodeBS') (Find.findThese o) + map (Git.Ref . encodeBS) (Find.findThese o) , Find.findThese = [] } diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -35,7 +35,7 @@ optParser :: CmdParamsDesc -> Parser FromKeyOptions optParser desc = FromKeyOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False seek :: FromKeyOptions -> CommandSeek seek o = do @@ -43,7 +43,7 @@ case (batchOption o, keyFilePairs o) of (Batch fmt, _) -> seekBatch matcher fmt -- older way of enabling batch input, does not support BatchNull - (NoBatch, []) -> seekBatch matcher BatchLine + (NoBatch, []) -> seekBatch matcher (BatchFormat BatchLine (BatchKeys False)) (NoBatch, ps) -> do force <- Annex.getState Annex.force withPairs (commandAction . start matcher force) ps diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -199,7 +199,7 @@ ) , return Nothing ) - getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter + getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter (RemoteVerify remote) dummymeter _ = noop getcheap tmp = case Remote.retrieveKeyFileCheap remote of Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp)) @@ -260,8 +260,9 @@ KeyUnlockedThin -> thawContent obj KeyLockedThin -> thawContent obj _ -> freezeContent obj - unlessM (isContentWritePermOk obj) $ - warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file" + checkContentWritePerm obj >>= \case + Nothing -> warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set" + _ -> return () whenM (liftIO $ R.doesPathExist $ parentDir obj) $ freezeContentDir obj @@ -292,7 +293,7 @@ fix InfoMissing warning $ "** Based on the location log, " ++ - decodeBS' (actionItemDesc ai) ++ + decodeBS (actionItemDesc ai) ++ "\n** was expected to be present, " ++ "but its content is missing." return False @@ -332,7 +333,7 @@ missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs warning $ "** Required content " ++ - decodeBS' (actionItemDesc ai) ++ + decodeBS (actionItemDesc ai) ++ " is missing from these repositories:\n" ++ missingrequired return False @@ -406,7 +407,7 @@ badsize a b = do msg <- bad key warning $ concat - [ decodeBS' (actionItemDesc ai) + [ decodeBS (actionItemDesc ai) , ": Bad file size (" , compareSizes storageUnits True a b , "); " @@ -424,11 +425,11 @@ case Types.Backend.canUpgradeKey backend of Just a | a key -> do warning $ concat - [ decodeBS' (actionItemDesc ai) + [ decodeBS (actionItemDesc ai) , ": Can be upgraded to an improved key format. " , "You can do so by running: git annex migrate --backend=" , decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " " - , decodeBS' file + , decodeBS file ] return True _ -> return True @@ -475,7 +476,7 @@ unless ok $ do msg <- bad key warning $ concat - [ decodeBS' (actionItemDesc ai) + [ decodeBS (actionItemDesc ai) , ": Bad file content; " , msg ] @@ -503,7 +504,7 @@ Nothing -> noop Just ic' -> whenM (compareInodeCaches ic ic') $ do warning $ concat - [ decodeBS' (actionItemDesc ai) + [ decodeBS (actionItemDesc ai) , ": Stale or missing inode cache; updating." ] Database.Keys.addInodeCaches key [ic] diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -34,7 +34,7 @@ <*> optional (parseRemoteOption <$> parseFromOption) <*> parseAutoOption <*> optional (parseIncompleteOption <|> parseKeyOptions <|> parseFailedTransfersOption) - <*> parseBatchOption + <*> parseBatchOption True seek :: GetOptions -> CommandSeek seek o = startConcurrency downloadStages $ do @@ -49,7 +49,7 @@ (commandAction . startKeys from) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (getFiles o) - Batch fmt -> batchAnnexedFilesMatching fmt seeker + Batch fmt -> batchAnnexed fmt seeker (startKeys from) where ww = WarnUnmatchLsFiles diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -85,7 +85,7 @@ [bs] -> let (branch, subdir) = separate (== ':') bs in RemoteImportOptions r - (Ref (encodeBS' branch)) + (Ref (encodeBS branch)) (if null subdir then Nothing else Just subdir) content ic @@ -200,13 +200,31 @@ -- Move or copy the src file to the dest file. -- The dest file is what will be ingested. createWorkTreeDirectory (parentDir destfile) - liftIO $ if mode == Duplicate || mode == SkipDuplicates - then void $ copyFileExternal CopyAllMetaData - (fromRawFilePath srcfile) - (fromRawFilePath destfile) - else moveFile - (fromRawFilePath srcfile) - (fromRawFilePath destfile) + unwind <- liftIO $ if mode == Duplicate || mode == SkipDuplicates + then do + void $ copyFileExternal CopyAllMetaData + (fromRawFilePath srcfile) + (fromRawFilePath destfile) + return $ removeWhenExistsWith R.removeLink destfile + else do + moveFile + (fromRawFilePath srcfile) + (fromRawFilePath destfile) + return $ moveFile + (fromRawFilePath destfile) + (fromRawFilePath srcfile) + -- Make sure that the dest file has its write permissions + -- removed; the src file normally already did, but may + -- have imported it from a filesystem that does not allow + -- removing write permissions, to a repo on a filesystem + -- that does. + when (lockingFile (lockDownConfig ld)) $ do + freezeContent destfile + checkLockedDownWritePerms destfile srcfile >>= \case + Just err -> do + liftIO unwind + giveup err + Nothing -> noop -- Get the inode cache of the dest file. It should be -- weakly the same as the originally locked down file's -- inode cache. (Since the file may have been copied, @@ -249,6 +267,12 @@ let cfg = LockDownConfig { lockingFile = lockingfile , hardlinkFileTmpDir = Nothing + -- The write perms of the file may not be able to be + -- removed, if it's being imported from a crippled + -- filesystem. So lockDown is asked to not check + -- the write perms. They will be checked later, after + -- the file gets copied into the repository. + , checkWritePerms = False } v <- lockDown cfg (fromRawFilePath srcfile) case v of diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -173,7 +173,7 @@ | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" | otherwise = withTmpFile "feed" $ \f h -> do liftIO $ hClose h - ifM (Url.withUrlOptions $ Url.download nullMeterUpdate url f) + ifM (Url.withUrlOptions $ Url.download nullMeterUpdate Nothing url f) ( Just <$> liftIO (readFileStrict f) , return Nothing ) diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -114,7 +114,7 @@ ( long "bytes" <> help "display file sizes in bytes" ) - <*> parseBatchOption + <*> parseBatchOption False seek :: InfoOptions -> CommandSeek seek o = case batchOption o of @@ -163,7 +163,7 @@ noInfo :: String -> SeekInput -> Annex () noInfo s si = do - showStart "info" (encodeBS' s) si + showStart "info" (encodeBS s) si showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid" showEndFail @@ -183,7 +183,7 @@ treeishInfo :: InfoOptions -> String -> SeekInput -> Annex () treeishInfo o t si = do - mi <- getTreeStatInfo o (Git.Ref (encodeBS' t)) + mi <- getTreeStatInfo o (Git.Ref (encodeBS t)) case mi of Nothing -> noInfo t si Just i -> showCustom (unwords ["info", t]) si $ do @@ -313,8 +313,8 @@ showStat s = maybe noop calc =<< s where calc (desc, a) = do - (lift . showHeader . encodeBS') desc - lift . showRaw . encodeBS' =<< a + (lift . showHeader . encodeBS) desc + lift . showRaw . encodeBS =<< a repo_list :: TrustLevel -> Stat repo_list level = stat n $ nojson $ lift $ do diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -230,7 +230,7 @@ [ Param $ Git.fromRef Annex.Branch.fullname , Param "--" ] ++ map Param fs - return (parseGitRawLog config (map decodeBL' ls), cleanup) + return (parseGitRawLog config (map decodeBL ls), cleanup) -- Parses chunked git log --raw output, which looks something like: -- diff --git a/Command/Merge.hs b/Command/Merge.hs --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -39,7 +39,7 @@ | otherwise = do prepMerge forM_ (mergeBranches o) $ - commandAction . mergeBranch o . Git.Ref . encodeBS' + commandAction . mergeBranch o . Git.Ref . encodeBS mergeAnnexBranch :: CommandStart mergeAnnexBranch = starting "merge" ai si $ do diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -44,7 +44,7 @@ <$> cmdParams desc <*> ((Get <$> getopt) <|> (Set <$> some modopts) <|> pure GetAll) <*> optional parseKeyOptions - <*> parseBatchOption + <*> parseBatchOption False where getopt = option (eitherReader (mkMetaField . T.pack)) ( long "get" <> short 'g' <> metavar paramField @@ -98,12 +98,12 @@ ) _ -> giveup "--batch is currently only supported in --json mode" -start :: VectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart start c o si file k = startKeys c o (si, k, mkActionItem (k, afile)) where afile = AssociatedFile (Just file) -startKeys :: VectorClock -> MetaDataOptions -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys :: CandidateVectorClock -> MetaDataOptions -> (SeekInput, Key, ActionItem) -> CommandStart startKeys c o (si, k, ai) = case getSet o of Get f -> startingCustomOutput k $ do l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k @@ -113,7 +113,7 @@ _ -> starting "metadata" ai si $ perform c o k -perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform +perform :: CandidateVectorClock -> MetaDataOptions -> Key -> CommandPerform perform c o k = case getSet o of Set ms -> do oldm <- getCurrentMetaData k diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -44,7 +44,7 @@ <*> parseFromToHereOptions <*> pure RemoveSafe <*> optional (parseKeyOptions <|> parseFailedTransfersOption) - <*> parseBatchOption + <*> parseBatchOption True instance DeferredParseClass MoveOptions where finishParse v = MoveOptions @@ -61,10 +61,10 @@ seek o = startConcurrency stages $ do case batchOption o of NoBatch -> withKeyOptions (keyOptions o) False seeker - (commandAction . startKey (fromToOptions o) (removeWhen o)) + (commandAction . keyaction) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (moveFiles o) - Batch fmt -> batchAnnexedFilesMatching fmt seeker + Batch fmt -> batchAnnexed fmt seeker keyaction where seeker = AnnexedFileSeeker { startAction = start (fromToOptions o) (removeWhen o) @@ -78,6 +78,7 @@ Right (FromRemote _) -> downloadStages Right (ToRemote _) -> commandStages Left ToHere -> downloadStages + keyaction = startKey (fromToOptions o) (removeWhen o) ww = WarnUnmatchLsFiles start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -33,7 +33,7 @@ optParser :: CmdParamsDesc -> Parser ReKeyOptions optParser desc = ReKeyOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False -- Split on the last space, since a FilePath can contain whitespace, -- but a Key very rarely does. diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -28,11 +28,12 @@ optParser :: CmdParamsDesc -> Parser RegisterUrlOptions optParser desc = RegisterUrlOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False seek :: RegisterUrlOptions -> CommandSeek seek o = case (batchOption o, keyUrlPairs o) of - (Batch fmt, _) -> commandAction $ startMass setUrlPresent fmt + (Batch (BatchFormat sep _), _) -> + commandAction $ startMass setUrlPresent sep -- older way of enabling batch input, does not support BatchNull (NoBatch, []) -> commandAction $ startMass setUrlPresent BatchLine (NoBatch, ps) -> withWords (commandAction . start setUrlPresent) ps @@ -46,14 +47,15 @@ si = SeekInput [keyname, url] start _ _ = giveup "specify a key and an url" -startMass :: (Key -> URLString -> Annex ()) -> BatchFormat -> CommandStart -startMass a fmt = +startMass :: (Key -> URLString -> Annex ()) -> BatchSeparator -> CommandStart +startMass a sep = starting "registerurl" (ActionItemOther (Just "stdin")) (SeekInput []) $ - performMass a fmt + performMass a sep -performMass :: (Key -> URLString -> Annex ()) -> BatchFormat -> CommandPerform -performMass a fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt +performMass :: (Key -> URLString -> Annex ()) -> BatchSeparator -> CommandPerform +performMass a sep = go True =<< map (separate (== ' ')) <$> batchLines fmt where + fmt = BatchFormat sep (BatchKeys False) go status [] = next $ return status go status ((keyname,u):rest) | not (null keyname) && not (null u) = do let key = keyOpt keyname diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -25,7 +25,7 @@ optParser :: CmdParamsDesc -> Parser RmUrlOptions optParser desc = RmUrlOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False seek :: RmUrlOptions -> CommandSeek seek o = case batchOption o of diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -26,7 +26,7 @@ optParser :: CmdParamsDesc -> Parser SetPresentKeyOptions optParser desc = SetPresentKeyOptions <$> cmdParams desc - <*> parseBatchOption + <*> parseBatchOption False seek :: SetPresentKeyOptions -> CommandSeek seek o = case batchOption o of diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -160,6 +160,7 @@ cfg = LockDownConfig { lockingFile = False , hardlinkFileTmpDir = Nothing + , checkWritePerms = True } -- git diff can run the clean filter on files outside the diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -297,7 +297,7 @@ Nothing -> return True Just verifier -> verifier k (serializeKey' k) get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate @@ -371,7 +371,7 @@ Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -63,12 +63,14 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ download' (uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> - tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case + logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file $ \t -> + tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case Right v -> return (True, v) Left e -> do warning (show e) return (False, UnVerified) + where + vc = RemoteVerify remote go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform go direction file a = notifyTransfer direction file a >>= liftIO . exitBool diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -51,7 +51,7 @@ | otherwise = notifyTransfer direction file $ download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case + r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (show e) return (False, UnVerified) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -56,7 +56,7 @@ -- and for retrying, and updating location log, -- and stall canceling. let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do - Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) + Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) in download' (Remote.uuid remote) key file Nothing noRetry go noNotification runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = @@ -73,7 +73,7 @@ notifyTransfer Download file $ download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case + r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (show e) return (False, UnVerified) diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -37,7 +37,7 @@ whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" where - current_branch = Git.Ref . encodeBS' . Prelude.head . lines . decodeBS' <$> revhead + current_branch = Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead revhead = inRepo $ Git.Command.pipeReadStrict [Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] diff --git a/Command/UnregisterUrl.hs b/Command/UnregisterUrl.hs --- a/Command/UnregisterUrl.hs +++ b/Command/UnregisterUrl.hs @@ -21,7 +21,7 @@ seek :: RegisterUrlOptions -> CommandSeek seek o = case (batchOption o, keyUrlPairs o) of - (Batch fmt, _) -> commandAction $ startMass unregisterUrl fmt + (Batch (BatchFormat sep _), _) -> commandAction $ startMass unregisterUrl sep (NoBatch, ps) -> withWords (commandAction . start unregisterUrl) ps unregisterUrl :: Key -> String -> Annex () diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -241,6 +241,7 @@ ourbranchend = S.cons (fromIntegral (ord '/')) (Git.fromRef' Annex.Branch.name) ourbranches (_, b) = not (ourbranchend `S.isSuffixOf` b) && not ("refs/synced/" `S.isPrefixOf` b) + && not ("refs/annex/" `S.isPrefixOf` b) && not (is_branchView (Git.Ref b)) getreflog rs = inRepo $ Git.RefLog.getMulti rs diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -311,7 +311,7 @@ let m = M.insert u l (cfgScheduleMap cfg) in Right $ cfg { cfgScheduleMap = m } | setting == "config" = - let m = M.insert (ConfigKey (encodeBS' f)) (ConfigValue (encodeBS' val)) (cfgGlobalConfigs cfg) + let m = M.insert (ConfigKey (encodeBS f)) (ConfigValue (encodeBS val)) (cfgGlobalConfigs cfg) in Right $ cfg { cfgGlobalConfigs = m } | setting == "numcopies" = case readish val of Nothing -> Left "parse error (expected an integer)" diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -39,7 +39,7 @@ optParser desc = WhereisOptions <$> cmdParams desc <*> optional parseKeyOptions - <*> parseBatchOption + <*> parseBatchOption True <*> optional parseFormatOption parseFormatOption :: Parser Utility.Format.Format @@ -62,7 +62,7 @@ (commandAction . startKeys o m) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (whereisFiles o) - Batch fmt -> batchAnnexedFilesMatching fmt seeker + Batch fmt -> batchAnnexed fmt seeker (startKeys o m) where ww = WarnUnmatchLsFiles diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -39,7 +39,7 @@ setConfig (ConfigKey key) value = do inRepo $ Git.Command.run [ Param "config" - , Param (decodeBS' key) + , Param (decodeBS key) , Param value ] reloadConfig diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -75,7 +75,7 @@ v <- a (SQL.ReadHandle qh) return (v, st) go DbClosed = do - st' <- openDb True DbClosed + st' <- openDb False DbClosed v <- case st' of (DbOpen qh) -> a (SQL.ReadHandle qh) _ -> return mempty @@ -97,7 +97,7 @@ v <- a (SQL.WriteHandle qh) return (v, st) go st = do - st' <- openDb False st + st' <- openDb True st v <- case st' of DbOpen qh -> a (SQL.WriteHandle qh) _ -> error "internal" diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -95,10 +95,10 @@ deriving (Eq, Show) toSSha :: Sha -> SSha -toSSha (Ref s) = SSha (decodeBS' s) +toSSha (Ref s) = SSha (decodeBS s) fromSSha :: SSha -> Ref -fromSSha (SSha s) = Ref (encodeBS' s) +fromSSha (SSha s) = Ref (encodeBS s) instance PersistField SSha where toPersistValue (SSha b) = toPersistValue b diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -170,7 +170,7 @@ {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool -isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' +isTrueFalse = isTrueFalse' . ConfigValue . encodeBS isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s) @@ -248,8 +248,8 @@ [ Param "config" , Param "--file" , File f - , Param (decodeBS' k) - , Param (decodeBS' v) + , Param (decodeBS k) + , Param (decodeBS v) ] {- Unsets a git config setting, in both the git repo, @@ -264,4 +264,4 @@ , return Nothing ) where - ps = [Param "config", Param "--unset-all", Param (decodeBS' k)] + ps = [Param "config", Param "--unset-all", Param (decodeBS k)] diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -31,7 +31,7 @@ "all" -> AllShared "world" -> AllShared "everybody" -> AllShared - _ -> maybe UnShared UmaskShared (readish (decodeBS' v)) + _ -> maybe UnShared UmaskShared (readish (decodeBS v)) Just NoConfigValue -> UnShared Nothing -> UnShared diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -114,7 +114,7 @@ go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of A.Done _ r -> r : go rest A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err - go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\"" + go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL s ++ "\"" -- : SP SP SP SP -- diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -159,7 +159,7 @@ ] r findShas :: [String] -> [Sha] -findShas = catMaybes . map (extractSha . encodeBS') +findShas = catMaybes . map (extractSha . encodeBS) . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l) diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -107,7 +107,7 @@ where defaultkey = "gcrypt.participants" parse (Just (ConfigValue "simple")) = [] - parse (Just (ConfigValue b)) = words (decodeBS' b) + parse (Just (ConfigValue b)) = words (decodeBS b) parse (Just NoConfigValue) = [] parse Nothing = [] @@ -122,4 +122,4 @@ remoteConfigKey :: S.ByteString -> RemoteName -> ConfigKey remoteConfigKey key remotename = ConfigKey $ - "remote." <> encodeBS' remotename <> "." <> key + "remote." <> encodeBS remotename <> "." <> key diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -251,7 +251,7 @@ unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo - return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) + return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup) where params = Param "ls-files" : @@ -277,7 +277,7 @@ then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) - sha <- extractSha (encodeBS' rawsha) + sha <- extractSha (encodeBS rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -149,7 +149,7 @@ - generated, so any size information is not included. -} formatLsTree :: TreeItem -> S.ByteString formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' '))) - [ encodeBS' (showOct (mode ti) "") + [ encodeBS (showOct (mode ti) "") , typeobj ti , fromRef' (sha ti) ] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti))) diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -82,7 +82,7 @@ {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref -dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d +dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} @@ -177,7 +177,7 @@ [ Param "rev-parse" , Param "--verify" , Param "--quiet" - , Param (decodeBS' ref') + , Param (decodeBS ref') ] where ref' = if ":" `S.isInfixOf` ref diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -37,7 +37,7 @@ remoteKeyToRemoteName (ConfigKey k) | "remote." `S.isPrefixOf` k = let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k - in if S.null n then Nothing else Just (decodeBS' n) + in if S.null n then Nothing else Just (decodeBS n) | otherwise = Nothing {- Construct a legal git remote name out of an arbitrary input string. @@ -90,7 +90,7 @@ | null insteadofs = l | otherwise = replacement ++ drop (S.length bestvalue) l where - replacement = decodeBS' $ S.drop (S.length prefix) $ + replacement = decodeBS $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey (bestkey, bestvalue) = case maximumBy longestvalue insteadofs of diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -252,7 +252,7 @@ getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath + let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -279,8 +279,8 @@ parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[]) - | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref -> - Just (Ref (encodeBS' sha), Ref (encodeBS' ref)) + | isJust (extractSha (encodeBS sha)) && Ref.legal True ref -> + Just (Ref (encodeBS sha), Ref (encodeBS ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly @@ -350,8 +350,8 @@ where parse l = case words l of (commitsha:treesha:[]) -> (,) - <$> extractSha (encodeBS' commitsha) - <*> extractSha (encodeBS' treesha) + <$> extractSha (encodeBS commitsha) + <*> extractSha (encodeBS treesha) _ -> Nothing check [] = return True check ((c, t):rest) @@ -469,7 +469,7 @@ where headfile = localGitDir g P. "HEAD" validhead s = "ref: refs/" `isPrefixOf` s - || isJust (extractSha (encodeBS' s)) + || isJust (extractSha (encodeBS s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -75,7 +75,7 @@ def = ConfigValue mempty fromConfigKey :: ConfigKey -> String -fromConfigKey (ConfigKey s) = decodeBS' s +fromConfigKey (ConfigKey s) = decodeBS s instance Show ConfigKey where show = fromConfigKey @@ -88,16 +88,16 @@ fromConfigValue NoConfigValue = mempty instance FromConfigValue String where - fromConfigValue = decodeBS' . fromConfigValue + fromConfigValue = decodeBS . fromConfigValue instance Show ConfigValue where show = fromConfigValue instance IsString ConfigKey where - fromString = ConfigKey . encodeBS' + fromString = ConfigKey . encodeBS instance IsString ConfigValue where - fromString = ConfigValue . encodeBS' + fromString = ConfigValue . encodeBS type RemoteName = String @@ -106,7 +106,7 @@ deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String -fromRef = decodeBS' . fromRef' +fromRef = decodeBS . fromRef' fromRef' :: Ref -> S.ByteString fromRef' (Ref s) = s diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -80,14 +80,14 @@ mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x] lsSubTree :: Ref -> FilePath -> Repo -> Streamer lsSubTree (Ref x) p repo streamer = do (s, cleanup) <- pipeNullSplit params repo mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -59,13 +59,13 @@ isChunkKey k = isJust (fromKey keyChunkSize k) && isJust (fromKey keyChunkNum k) serializeKey :: Key -> String -serializeKey = decodeBS' . serializeKey' +serializeKey = decodeBS . serializeKey' serializeKey' :: Key -> S.ByteString serializeKey' = keySerialization deserializeKey :: String -> Maybe Key -deserializeKey = deserializeKey' . encodeBS' +deserializeKey = deserializeKey' . encodeBS deserializeKey' :: S.ByteString -> Maybe Key deserializeKey' = eitherToMaybe . A.parseOnly keyParser diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -97,9 +97,8 @@ hereuuid <- getUUID let ep = ExportParticipants { exportFrom = hereuuid, exportTo = remoteuuid } let exported = mkExported (newTreeish ec) [] - Annex.Branch.change - (Annex.Branch.RegardingUUID [remoteuuid, hereuuid]) - exportLog $ + let ru = Annex.Branch.RegardingUUID [remoteuuid, hereuuid] + Annex.Branch.change ru exportLog $ buildExportLog . changeMapLog c ep exported . M.mapWithKey (updateForExportChange remoteuuid ec c hereuuid) diff --git a/Logs/Export/Pure.hs b/Logs/Export/Pure.hs --- a/Logs/Export/Pure.hs +++ b/Logs/Export/Pure.hs @@ -23,6 +23,7 @@ ) where import Annex.Common +import Annex.VectorClock import qualified Git import Logs.MapLog @@ -110,7 +111,9 @@ -- This way, when multiple repositories are exporting to -- the same special remote, there's no conflict as long as they move -- forward in lock-step. -updateForExportChange :: UUID -> ExportChange -> VectorClock -> UUID -> ExportParticipants -> LogEntry Exported -> LogEntry Exported -updateForExportChange remoteuuid ec c hereuuid ep le@(LogEntry _ exported@(Exported { exportedTreeish = t })) +updateForExportChange :: UUID -> ExportChange -> CandidateVectorClock -> UUID -> ExportParticipants -> LogEntry Exported -> LogEntry Exported +updateForExportChange remoteuuid ec c hereuuid ep le@(LogEntry lc exported@(Exported { exportedTreeish = t })) | hereuuid == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le - | otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec }) + | otherwise = LogEntry c' (exported { exportedTreeish = newTreeish ec }) + where + c' = advanceVectorClock c [lc] diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -54,7 +54,7 @@ deserialize ("truncated":ls) = deserialize' ls True deserialize ls = deserialize' ls False deserialize' ls t = - let s = S.fromList $ map (Ref . encodeBS') ls + let s = S.fromList $ map (Ref . encodeBS) ls in if S.null s then FsckFailed else FsckFoundMissing s t clearFsckResults :: UUID -> Annex () diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -8,7 +8,7 @@ - Repositories record their UUID and the date when they --get or --drop - a value. - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -61,14 +61,14 @@ {- Log a change in the presence of a key's value in a repository. -} logChange :: Key -> UUID -> LogStatus -> Annex () -logChange = logChange' logNow - -logChange' :: (LogStatus -> LogInfo -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex () -logChange' mklog key u@(UUID _) s = do +logChange key u@(UUID _) s = do config <- Annex.getGitConfig - maybeAddLog (Annex.Branch.RegardingUUID [u]) (locationLogFile config key) - =<< mklog s (LogInfo (fromUUID u)) -logChange' _ _ NoUUID _ = noop + maybeAddLog + (Annex.Branch.RegardingUUID [u]) + (locationLogFile config key) + s + (LogInfo (fromUUID u)) +logChange _ NoUUID _ = noop {- Returns a list of repository UUIDs that, according to the log, have - the value of a key. -} @@ -107,6 +107,9 @@ - - Changes all logged lines for the key, in any location, that are - currently InfoMissing, to be InfoDead. + - + - The vector clock in the log is updated minimally, so that any + - other location log changes are guaranteed to overrule this. -} setDead :: Key -> Annex () setDead key = do @@ -117,18 +120,12 @@ where go logfile l = let u = toUUID (fromLogInfo (info l)) - in addLog (Annex.Branch.RegardingUUID [u]) logfile (setDead' l) - -{- Note that the timestamp in the log is updated minimally, so that this - - can be overruled by other location log changes. -} -setDead' :: LogLine -> LogLine -setDead' l = l - { status = InfoDead - , date = case date l of - VectorClock c -> VectorClock $ - c + realToFrac (picosecondsToDiffTime 1) - Unknown -> Unknown - } + c = case date l of + VectorClock v -> CandidateVectorClock $ + v + realToFrac (picosecondsToDiffTime 1) + Unknown -> CandidateVectorClock 0 + in addLog' (Annex.Branch.RegardingUUID [u]) logfile InfoDead + (info l) c data Unchecked a = Unchecked (Annex (Maybe a)) diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -67,8 +67,12 @@ A.endOfInput return (f, LogEntry c v) -changeMapLog :: Ord f => VectorClock -> f -> v -> MapLog f v -> MapLog f v -changeMapLog c f v = M.insert f $ LogEntry c v +changeMapLog :: Ord f => CandidateVectorClock -> f -> v -> MapLog f v -> MapLog f v +changeMapLog c f v m = M.insert f (LogEntry c' v) m + where + c' = case M.lookup f m of + Nothing -> advanceVectorClock c [] + Just old -> advanceVectorClock c [changed old] {- Only add an LogEntry if it's newer (or at least as new as) than any - existing LogEntry for a field. -} diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -105,22 +105,23 @@ addMetaData' ru getlogfile k metadata = addMetaDataClocked' ru getlogfile k metadata =<< currentVectorClock -{- Reusing the same VectorClock when making changes to the metadata +{- Reusing the same CandidateVectorClock 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. -} -addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex () +addMetaDataClocked :: Key -> MetaData -> CandidateVectorClock -> Annex () addMetaDataClocked = addMetaDataClocked' (Annex.Branch.RegardingUUID []) metaDataLogFile -addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> VectorClock -> Annex () +addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> CandidateVectorClock -> Annex () addMetaDataClocked' ru getlogfile k d@(MetaData m) c | d == emptyMetaData = noop | otherwise = do config <- Annex.getGitConfig - Annex.Branch.change ru (getlogfile config k) $ - buildLog . simplifyLog - . S.insert (LogEntry c metadata) - . parseLog + Annex.Branch.change ru (getlogfile config k) $ \b -> + let s = parseLog b + c' = advanceVectorClock c (map changed (S.toList s)) + ent = LogEntry c' metadata + in buildLog $ simplifyLog $ S.insert ent s where metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -6,7 +6,7 @@ - A line of the log will look like: "date N INFO" - Where N=1 when the INFO is present, 0 otherwise. - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,9 +14,9 @@ module Logs.Presence ( module X, addLog, + addLog', maybeAddLog, readLog, - logNow, currentLog, currentLogInfo, historicalLogInfo, @@ -28,31 +28,42 @@ import qualified Annex.Branch import Git.Types (RefDate) -{- Adds a LogLine to the log, removing any LogLines that are obsoleted by - - adding it. -} -addLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogLine -> Annex () -addLog ru file line = Annex.Branch.change ru file $ \b -> - buildLog $ compactLog (line : parseLog b) +{- Adds to the log, removing any LogLines that are obsoleted. -} +addLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () +addLog ru file logstatus loginfo = + addLog' ru file logstatus loginfo =<< currentVectorClock +addLog' :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> CandidateVectorClock -> Annex () +addLog' ru file logstatus loginfo c = + Annex.Branch.change ru file $ \b -> + let old = parseLog b + line = genLine logstatus loginfo c old + in buildLog $ compactLog (line : old) + {- When a LogLine already exists with the same status and info, but an - older timestamp, that LogLine is preserved, rather than updating the log - with a newer timestamp. -} -maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogLine -> Annex () -maybeAddLog ru file line = Annex.Branch.maybeChange ru file $ \s -> do - m <- insertNewStatus line $ logMap $ parseLog s - return $ buildLog $ mapLog m +maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () +maybeAddLog ru file logstatus loginfo = do + c <- currentVectorClock + Annex.Branch.maybeChange ru file $ \b -> + let old = parseLog b + line = genLine logstatus loginfo c old + in do + m <- insertNewStatus line $ logMap old + return $ buildLog $ mapLog m +genLine :: LogStatus -> LogInfo -> CandidateVectorClock -> [LogLine] -> LogLine +genLine logstatus loginfo c old = LogLine c' logstatus loginfo + where + oldcs = map date (filter (\l -> info l == loginfo) old) + c' = advanceVectorClock c oldcs + {- Reads a log file. - Note that the LogLines returned may be in any order. -} readLog :: RawFilePath -> Annex [LogLine] readLog = parseLog <$$> Annex.Branch.get - -{- Generates a new LogLine with the current time. -} -logNow :: LogStatus -> LogInfo -> Annex LogLine -logNow s i = do - c <- currentVectorClock - return $ LogLine c s i {- Reads a log and returns only the info that is still in effect. -} currentLogInfo :: RawFilePath -> Annex [LogInfo] diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -19,6 +19,7 @@ import qualified Data.Attoparsec.ByteString.Lazy as A import Data.Attoparsec.ByteString.Char8 (char, anyChar) import Data.ByteString.Builder +import Data.Char newtype LogInfo = LogInfo { fromLogInfo :: S.ByteString } deriving (Show, Eq, Ord) @@ -119,8 +120,15 @@ <*> elements [minBound..maxBound] <*> (LogInfo <$> arbinfo) where - arbinfo = (encodeBS <$> arbitrary) `suchThat` - (\b -> C8.notElem '\n' b && C8.notElem '\r' b) + -- Avoid newline characters, which cannot appear in + -- LogInfo. + -- + -- Avoid non-ascii values because fully arbitrary + -- strings may not be encoded using the filesystem + -- encoding, which is normally applied to all input. + arbinfo = (encodeBS <$> arbitrary `suchThat` all isAscii) + `suchThat` (\b -> C8.notElem '\n' b && C8.notElem '\r' b) prop_parse_build_presence_log :: [LogLine] -> Bool -prop_parse_build_presence_log l = parseLog (toLazyByteString (buildLog l)) == l +prop_parse_build_presence_log l = + parseLog (toLazyByteString (buildLog l)) == l diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + {- git-annex single-value log - - This is used to store a value in a way that can be union merged. @@ -6,7 +8,7 @@ - - The line with the newest timestamp wins. - - - Copyright 2014 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -31,8 +33,10 @@ getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v) getLog = newestValue <$$> readLog -setLog :: (SingleValueSerializable v) => Annex.Branch.RegardingUUID -> RawFilePath -> v -> Annex () +setLog :: (Ord v, SingleValueSerializable v) => Annex.Branch.RegardingUUID -> RawFilePath -> v -> Annex () setLog ru f v = do c <- currentVectorClock - let ent = LogEntry c v - Annex.Branch.change ru f $ \_old -> buildLog (S.singleton ent) + Annex.Branch.change ru f $ \old -> + let oldcs = map changed ((parseLog' old) `asTypeOf` [ent]) + ent = LogEntry (advanceVectorClock c oldcs) v + in buildLog (S.singleton ent) diff --git a/Logs/SingleValue/Pure.hs b/Logs/SingleValue/Pure.hs --- a/Logs/SingleValue/Pure.hs +++ b/Logs/SingleValue/Pure.hs @@ -1,6 +1,6 @@ {- git-annex single-value log, pure operations - - - Copyright 2014-2019 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -33,13 +33,18 @@ buildLog = mconcat . map genline . S.toList where genline (LogEntry c v) = - buildVectorClock c <> sp <> byteString (serialize v) <> nl + buildVectorClock c + <> sp + <> byteString (serialize v) + <> nl sp = charUtf8 ' ' nl = charUtf8 '\n' parseLog :: (Ord v, SingleValueSerializable v) => L.ByteString -> Log v -parseLog = S.fromList . fromMaybe [] - . A.maybeResult . A.parse (logParser <* A.endOfInput) +parseLog = S.fromList . parseLog' + +parseLog' :: SingleValueSerializable v => L.ByteString -> [LogEntry v] +parseLog' = fromMaybe [] . A.maybeResult . A.parse (logParser <* A.endOfInput) logParser :: SingleValueSerializable v => A.Parser [LogEntry v] logParser = parseLogLines $ LogEntry diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -35,7 +35,7 @@ describeTransfer t info = unwords [ show $ transferDirection t , show $ transferUUID t - , decodeBS' $ actionItemDesc $ ActionItemAssociatedFile + , decodeBS $ actionItemDesc $ ActionItemAssociatedFile (associatedFile info) (transferKey t) , show $ bytesComplete info diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -51,8 +51,12 @@ noTransitions :: Transitions noTransitions = S.empty -addTransition :: VectorClock -> Transition -> Transitions -> Transitions -addTransition c t = S.insert $ TransitionLine c (Right t) +addTransition :: CandidateVectorClock -> Transition -> Transitions -> Transitions +addTransition c t s = S.insert (TransitionLine c' (Right t)) s + where + oldcs = map transitionStarted $ + filter (\l -> transition l == Right t) (S.toList s) + c' = advanceVectorClock c oldcs buildTransitions :: Transitions -> Builder buildTransitions = mconcat . map genline . S.elems @@ -72,9 +76,6 @@ in if S.null $ S.filter (isLeft . transition) ts then ts else giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!" - -showTransitionLine :: TransitionLine -> String -showTransitionLine (TransitionLine c t) = unwords [show t, formatVectorClock c] transitionLineParser :: A.Parser TransitionLine transitionLineParser = do diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -53,8 +53,10 @@ buildLogOld builder = mconcat . map genline . M.toList where genline (u, LogEntry c@(VectorClock {}) v) = - buildUUID u <> sp <> builder v <> sp <> - byteString "timestamp=" <> buildVectorClock c <> nl + buildUUID u <> sp <> builder v <> sp + <> byteString "timestamp=" + <> buildVectorClock c + <> nl genline (u, LogEntry Unknown v) = buildUUID u <> sp <> builder v <> nl sp = charUtf8 ' ' @@ -89,7 +91,7 @@ parseLogNew :: A.Parser v -> L.ByteString -> Log v parseLogNew = parseMapLog (toUUID <$> A.takeByteString) -changeLog :: VectorClock -> UUID -> v -> Log v -> Log v +changeLog :: CandidateVectorClock -> UUID -> v -> Log v -> Log v changeLog = changeMapLog addLog :: UUID -> LogEntry v -> Log v -> Log v diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -74,7 +74,7 @@ | B.null name = Git.Ref branchViewPrefix | otherwise = Git.Ref $ branchViewPrefix <> "/" <> name where - name = encodeBS' $ + name = encodeBS $ intercalate ";" $ map branchcomp (viewComponents view) branchcomp c | viewVisible c = branchcomp' c diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -61,7 +61,7 @@ unless (url `elem` us) $ do config <- Annex.getGitConfig addLog (Annex.Branch.RegardingUUID []) (urlLogFile config key) - =<< logNow InfoPresent (LogInfo (encodeBS url)) + InfoPresent (LogInfo (encodeBS url)) -- If the url does not have an OtherDownloader, it must be present -- in the web. case snd (getDownloader url) of @@ -75,7 +75,7 @@ when (url `elem` us) $ do config <- Annex.getGitConfig addLog (Annex.Branch.RegardingUUID []) (urlLogFile config key) - =<< logNow InfoMissing (LogInfo (encodeBS url)) + InfoMissing (LogInfo (encodeBS url)) -- If the url was a web url and none of the remaining urls -- for the key are web urls, the key must not be present -- in the web. diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -72,18 +72,18 @@ showStart :: String -> RawFilePath -> SeekInput -> Annex () showStart command file si = outputMessage json $ - encodeBS' command <> " " <> file <> " " + encodeBS command <> " " <> file <> " " where json = JSON.start command (Just file) Nothing si showStartKey :: String -> Key -> ActionItem -> SeekInput -> Annex () showStartKey command key ai si = outputMessage json $ - encodeBS' command <> " " <> actionItemDesc ai <> " " + encodeBS command <> " " <> actionItemDesc ai <> " " where json = JSON.start command (actionItemFile ai) (Just key) si showStartOther :: String -> Maybe String -> SeekInput -> Annex () -showStartOther command mdesc si = outputMessage json $ encodeBS' $ +showStartOther command mdesc si = outputMessage json $ encodeBS $ command ++ (maybe "" (" " ++) mdesc) ++ " " where json = JSON.start command Nothing Nothing si @@ -116,7 +116,7 @@ showEndMessage (CustomOutput _) = const noop showNote :: String -> Annex () -showNote s = outputMessage (JSON.note s) $ encodeBS' $ "(" ++ s ++ ") " +showNote s = outputMessage (JSON.note s) $ encodeBS $ "(" ++ s ++ ") " showAction :: String -> Annex () showAction s = showNote $ s ++ "..." @@ -131,7 +131,7 @@ Annex.changeState $ \s -> s { Annex.output = st' } | sideActionBlock st == InBlock = return () | otherwise = go' - go' = outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n" + go' = outputMessage JSON.none $ encodeBS $ "(" ++ m ++ "...)\n" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git" @@ -175,7 +175,7 @@ outputMessage JSON.none "\n" showLongNote :: String -> Annex () -showLongNote s = outputMessage (JSON.note s) (encodeBS' (formatLongNote s)) +showLongNote s = outputMessage (JSON.note s) (encodeBS (formatLongNote s)) formatLongNote :: String -> String formatLongNote s = '\n' : indent s ++ "\n" @@ -184,7 +184,7 @@ -- to console, but json object containing the info is emitted immediately. showInfo :: String -> Annex () showInfo s = outputMessage' outputJSON (JSON.info s) $ - encodeBS' (formatLongNote s) + encodeBS (formatLongNote s) showEndOk :: Annex () showEndOk = showEndResult True diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -202,10 +202,12 @@ runner validitycheck >>= \case Right (Just Valid) -> case incrementalverifier of - Just iv -> ifM (liftIO (finalizeIncremental iv) <&&> pure rightsize) - ( return (True, Verified) - , return (False, UnVerified) - ) + Just iv + | rightsize -> liftIO (finalizeIncremental iv) >>= \case + Nothing -> return (True, UnVerified) + Just True -> return (True, Verified) + Just False -> return (False, UnVerified) + | otherwise -> return (False, UnVerified) Nothing -> return (rightsize, UnVerified) Right (Just Invalid) | l == 0 -> -- Special case, for when diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -17,9 +17,9 @@ import Types (Annex) import Types.Key import Types.UUID -import Types.Remote (Verification(..)) -import Types.Backend (IncrementalVerifier(..)) import Types.Transfer +import Types.Remote (Verification(..)) +import Utility.Hash (IncrementalVerifier(..)) import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude @@ -172,7 +172,7 @@ instance Proto.Serializable ProtoAssociatedFile where serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = "" serialize (ProtoAssociatedFile (AssociatedFile (Just af))) = - decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af + decodeBS $ toInternalGitPath $ encodeBS $ concatMap esc $ fromRawFilePath af where esc '%' = "%%" esc c diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -153,7 +153,7 @@ {- Finds the remote or remote group matching the name. -} byNameOrGroup :: RemoteName -> Annex [Remote] -byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n)) +byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS n)) where go (Just l) = catMaybes <$> mapM (byName . Just) (splitc ' ' (fromConfigValue l)) diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Remote.Adb (remote) where import Annex.Common @@ -189,7 +191,7 @@ retrieve :: AndroidSerial -> AndroidPath -> Retriever retrieve serial adir = fileRetriever $ \dest k _p -> let src = androidLocation adir k - in retrieve' serial src dest + in retrieve' serial src (fromRawFilePath dest) retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex () retrieve' serial src dest = @@ -307,7 +309,7 @@ mk ('S':'T':'\t':l) = let (stat, fn) = separate (== '\t') l sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat)) - cid = ContentIdentifier (encodeBS' stat) + cid = ContentIdentifier (encodeBS stat) loc = mkImportLocation $ toRawFilePath $ Posix.makeRelative (fromAndroidPath adir) fn in Just (loc, (cid, sz)) @@ -440,7 +442,7 @@ return $ case ls of Just ["n"] -> Right Nothing Just (('S':'T':'\t':stat):[]) -> Right $ Just $ - ContentIdentifier (encodeBS' stat) + ContentIdentifier (encodeBS stat) _ -> Left (ExitFailure 1) where aloc = fromAndroidPath $ androidExportLocation adir loc diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -96,8 +96,8 @@ , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -downloadKey key _file dest p = do +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey key _file dest p _ = do get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key -- While bittorrent verifies the hash in the torrent file, -- the torrent file itself is downloaded without verification, @@ -215,7 +215,7 @@ liftIO $ hClose h resetAnnexFilePerm (toRawFilePath f) ok <- Url.withUrlOptions $ - Url.download nullMeterUpdate u f + Url.download nullMeterUpdate Nothing u f when ok $ liftIO $ renameFile f (fromRawFilePath torrent) return ok diff --git a/Remote/Borg.hs b/Remote/Borg.hs --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -149,7 +149,7 @@ borgLocal (BorgRepo r) = notElem ':' r borgArchive :: BorgRepo -> BorgArchiveName -> String -borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS' n +borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS n absBorgRepo :: BorgRepo -> IO BorgRepo absBorgRepo r@(BorgRepo p) diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Remote.Bup (remote) where import qualified Data.Map as M @@ -184,10 +186,11 @@ bracketIO (createProcess p) cleanupProcess (go sink p) where go sink p (_, Just h, _, pid) = do - () <- sink =<< liftIO (L.hGetContents h) + r <- sink =<< liftIO (L.hGetContents h) liftIO $ do hClose h forceSuccessProcess p pid + return r go _ _ _ = error "internal" {- Cannot revert having stored a key in bup, but at least the data for the diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} module Remote.Ddar (remote) where @@ -166,10 +167,11 @@ bracketIO (createProcess p) cleanupProcess (go sink p) where go sink p (_, Just h, _, pid) = do - () <- sink =<< liftIO (L.hGetContents h) + r <- sink =<< liftIO (L.hGetContents h) liftIO $ do hClose h forceSuccessProcess p pid + return r go _ _ _ = error "internal" remove :: DdarRepo -> Remover diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Remote.Directory ( @@ -190,7 +191,7 @@ in byteStorer go k c m NoChunks -> let go _k src p = do - fileCopierUnVerified cow src tmpf k p + void $ fileCopier cow src tmpf p Nothing liftIO $ finalizeStoreGeneric d tmpdir destdir in fileStorer go k c m _ -> @@ -204,11 +205,6 @@ kf = keyFile k destdir = storeDir d k -fileCopierUnVerified :: CopyCoWTried -> FilePath -> FilePath -> Key -> MeterUpdate -> Annex () -fileCopierUnVerified cow src dest k p = do - (ok, _verification) <- fileCopier cow src dest k p (return True) NoVerify - unless ok $ giveup "failed to copy file" - checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool checkDiskSpaceDirectory d k = do annexdir <- fromRepo gitAnnexObjectDir @@ -236,9 +232,9 @@ retrieveKeyFileM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Retriever retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations d -retrieveKeyFileM d NoChunks cow = fileRetriever $ \dest k p -> do +retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do src <- liftIO $ fromRawFilePath <$> getLocation d k - fileCopierUnVerified cow src dest k p + void $ fileCopier cow src (fromRawFilePath dest) p iv retrieveKeyFileM d _ _ = byteRetriever $ \k sink -> sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k) @@ -304,17 +300,17 @@ ) storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () -storeExportM d cow src k loc p = do +storeExportM d cow src _k loc p = do liftIO $ createDirectoryUnder d (P.takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. viaTmp go (fromRawFilePath dest) () where dest = exportPath d loc - go tmp () = fileCopierUnVerified cow src tmp k p + go tmp () = void $ fileCopier cow src tmp p Nothing retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () -retrieveExportM d cow k loc dest p = fileCopierUnVerified cow src dest k p +retrieveExportM d cow _k loc dest p = void $ fileCopier cow src dest p Nothing where src = fromRawFilePath $ exportPath d loc @@ -492,11 +488,11 @@ guardSameContentIdentifiers cont cid currcid storeExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier -storeExportWithContentIdentifierM dir cow src k loc overwritablecids p = do +storeExportWithContentIdentifierM dir cow src _k loc overwritablecids p = do liftIO $ createDirectoryUnder dir (toRawFilePath destdir) withTmpFileIn destdir template $ \tmpf tmph -> do liftIO $ hClose tmph - fileCopierUnVerified cow src tmpf k p + void $ fileCopier cow src tmpf p Nothing let tmpf' = toRawFilePath tmpf resetAnnexFilePerm tmpf' liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf' >>= \case diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -8,6 +8,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Remote.Directory.LegacyChunked where @@ -97,7 +98,7 @@ - :/ This is legacy code.. -} retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever -retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do +retrieve locations d basek p miv c = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." let tmp = tmpdir P. keyFile basek <> ".directorylegacy.tmp" let tmp' = fromRawFilePath tmp @@ -109,7 +110,7 @@ b <- liftIO $ L.readFile tmp' liftIO $ removeWhenExistsWith R.removeLink tmp sink b - byteRetriever go basek p c + byteRetriever go basek p miv c checkKey :: RawFilePath -> (RawFilePath -> Key -> [RawFilePath]) -> Key -> Annex Bool checkKey d locations k = liftIO $ diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} module Remote.External (remote) where @@ -66,17 +67,19 @@ | externaltype == "readonly" = do c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost - mk c cst GloballyAvailable - readonlyStorer - retrieveUrl - readonlyRemoveKey - checkKeyUrl + let rmt = mk c cst GloballyAvailable Nothing (externalInfo externaltype) Nothing Nothing exportUnsupported exportUnsupported + return $ Just $ specialRemote c + readonlyStorer + retrieveUrl + readonlyRemoveKey + checkKeyUrl + rmt | otherwise = do c <- parsedRemoteConfig remote rc external <- newExternal externaltype (Just u) c (Just gc) @@ -103,20 +106,22 @@ let cheapexportsupported = if exportsupported then exportIsSupported else exportUnsupported - mk c cst avail - (storeKeyM external) - (retrieveKeyFileM external) - (removeKeyM external) - (checkPresentM external) + let rmt = mk c cst avail (Just (whereisKeyM external)) (getInfoM external) (Just (claimUrlM external)) (Just (checkUrlM external)) exportactions cheapexportsupported + return $ Just $ specialRemote c + (storeKeyM external) + (retrieveKeyFileM external) + (removeKeyM external) + (checkPresentM external) + rmt where - mk c cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do - let rmt = Remote + mk c cst avail towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = + Remote { uuid = u , cost = cst , name = Git.repoDescribe r @@ -154,12 +159,6 @@ , checkUrl = tocheckurl , remoteStateHandle = rs } - return $ Just $ specialRemote c - tostore - toretrieve - toremove - tocheckkey - rmt externaltype = fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc) externalSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) @@ -238,7 +237,7 @@ retrieveKeyFileM external = fileRetriever $ \d k p -> either giveup return =<< go d k p where - go d k p = handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp -> + go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromRawFilePath d)) k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Download k' | k == k' -> result $ Right () @@ -809,9 +808,9 @@ mkmulti (u, s, f) = (u, s, f) retrieveUrl :: Retriever -retrieveUrl = fileRetriever $ \f k p -> do +retrieveUrl = fileRetriever' $ \f k p iv -> do us <- getWebUrls k - unlessM (withUrlOptions $ downloadUrl k p us f) $ + unlessM (withUrlOptions $ downloadUrl True k p iv us (fromRawFilePath f)) $ giveup "failed to download content" checkKeyUrl :: CheckPresent diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Remote.GCrypt ( remote, @@ -311,7 +312,7 @@ , Param tmpconfig ] liftIO $ do - void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS' gcryptid) + void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS gcryptid) void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False) ok <- liftIO $ rsync $ opts ++ [ Param "--recursive" @@ -406,9 +407,9 @@ storersync = fileStorer $ Remote.Rsync.store rsyncopts retrieve :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Retriever -retrieve r rsyncopts accessmethod k p sink = do +retrieve r rsyncopts accessmethod k p miv sink = do repo <- getRepo r - retrieve' repo r rsyncopts accessmethod k p sink + retrieve' repo r rsyncopts accessmethod k p miv sink retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Retriever retrieve' repo r rsyncopts accessmethod @@ -417,7 +418,8 @@ sink =<< liftIO (L.readFile $ gCryptLocation repo k) | Git.repoIsSsh repo = if accessShell r then fileRetriever $ \f k p -> do - ps <- Ssh.rsyncParamsRemote False r Download k f + ps <- Ssh.rsyncParamsRemote False r Download k + (fromRawFilePath f) (AssociatedFile Nothing) oh <- mkOutputHandler unlessM (Ssh.rsyncHelper oh (Just p) ps) $ diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -29,6 +29,7 @@ import Logs.Presence import Annex.Transfer import Annex.CopyFile +import Annex.Verify import Annex.UUID import qualified Annex.Content import qualified Annex.BranchState @@ -291,7 +292,7 @@ let url = Git.repoLocation r ++ "/config" v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do liftIO $ hClose h - Url.download' nullMeterUpdate url tmpfile uo >>= \case + Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case Right () -> pipedconfig Git.Config.ConfigNullList False url "git" [ Param "config" @@ -528,23 +529,24 @@ failedlock = giveup "can't lock content" {- Tries to copy a key's content from a remote's annex to a file. -} -copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification +copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification copyFromRemote = copyFromRemote' False -copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -copyFromRemote' forcersync r st key file dest meterupdate = do +copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +copyFromRemote' forcersync r st key file dest meterupdate vc = do repo <- getRepo r - copyFromRemote'' repo forcersync r st key file dest meterupdate + copyFromRemote'' repo forcersync r st key file dest meterupdate vc -copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate +copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate vc | Git.repoIsHttp repo = do + iv <- startVerifyKeyContentIncrementally vc key gc <- Annex.getGitConfig ok <- Url.withUrlOptionsPromptingCreds $ - Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest + Annex.Content.downloadUrl False key meterupdate iv (keyUrls gc repo r key) dest unless ok $ giveup "failed to download content" - return UnVerified + snd <$> finishVerifyKeyContentIncrementally iv | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do u <- getUUID hardlink <- wantHardLink @@ -554,12 +556,11 @@ let checksuccess = check >>= \case Just err -> giveup err Nothing -> return True - let verify = Annex.Content.RemoteVerify r copier <- mkFileCopier hardlink st (ok, v) <- runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> - copier object dest key p' checksuccess verify + copier object dest key p' checksuccess vc if ok then return v else giveup "failed to retrieve content from remote" @@ -571,9 +572,8 @@ then return v else giveup "failed to retrieve content from remote" else P2PHelper.retrieve - (Annex.Content.RemoteVerify r) (\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p)) - key file dest meterupdate + key file dest meterupdate vc | otherwise = giveup "copying from non-ssh, non-http remote not supported" where fallback p = unVerified $ feedprogressback $ \p' -> do @@ -698,7 +698,7 @@ res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) ( return True , runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do - let verify = Annex.Content.RemoteVerify r + let verify = RemoteVerify r copier <- mkFileCopier hardlink st let rsp = RetrievalAllKeysSecure let checksuccess = liftIO checkio >>= \case @@ -839,9 +839,18 @@ -- because they can be modified at any time. <&&> (not <$> annexThin <$> Annex.getGitConfig) +type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification) + +-- If either the remote or local repository wants to use hard links, +-- the copier will do so (falling back to copying if a hard link cannot be +-- made). +-- +-- When a hard link is created, returns Verified; the repo being linked +-- from is implicitly trusted, so no expensive verification needs to be +-- done. Also returns Verified if the key's content is verified while +-- copying it. mkFileCopier :: Bool -> State -> Annex FileCopier mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do - let copier = fileCopier copycowtried localwanthardlink <- wantHardLink let linker = \src dest -> createLink src dest >> return True if remotewanthardlink || localwanthardlink @@ -854,6 +863,15 @@ , copier src dest k p check verifyconfig ) else return copier + where + copier src dest k p check verifyconfig = do + iv <- startVerifyKeyContentIncrementally verifyconfig k + fileCopier copycowtried src dest p iv >>= \case + Copied -> ifM check + ( finishVerifyKeyContentIncrementally iv + , return (False, UnVerified) + ) + CopiedCoW -> unVerified check {- Normally the UUID of a local repository is checked at startup, - but annex-checkuuid config can prevent that. To avoid getting diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Remote.GitLFS (remote, gen, configKnownUrl) where @@ -213,7 +214,7 @@ set k v r' = do let k' = remoteAnnexConfig r' k setConfig k' v - return $ Git.Config.store' k' (Git.ConfigValue (encodeBS' v)) r' + return $ Git.Config.store' k' (Git.ConfigValue (encodeBS v)) r' data LFSHandle = LFSHandle { downloadEndpoint :: Maybe LFS.Endpoint @@ -475,7 +476,7 @@ makeSmallAPIRequest . setRequestCheckStatus retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever -retrieve rs h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case +retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownload h >>= \case Nothing -> giveup "unable to connect to git-lfs endpoint" Just endpoint -> mkDownloadRequest rs k >>= \case Nothing -> giveup "unable to download this object from git-lfs" @@ -486,9 +487,9 @@ (tro:_) | LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size -> giveup "git-lfs server replied with other object than the one we requested" - | otherwise -> go dest p tro + | otherwise -> go dest p iv tro where - go dest p tro = case LFS.resp_error tro of + go dest p iv tro = case LFS.resp_error tro of Just err -> giveup $ T.unpack $ LFS.respobjerr_message err Nothing -> case LFS.resp_actions tro of Nothing -> giveup "git-lfs server did not provide a way to download this object" @@ -496,7 +497,7 @@ Nothing -> giveup "unable to parse git-lfs server download url" Just req -> do uo <- getUrlOptions - liftIO $ downloadConduit p req dest uo + liftIO $ downloadConduit p iv req (fromRawFilePath dest) uo -- Since git-lfs does not support removing content, nothing needs to be -- done to lock content in the remote, except for checking that the content diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Remote.Glacier (remote, jobList, checkSaneGlacierCommand) where import qualified Data.Map as M @@ -176,7 +178,7 @@ retrieve :: Remote -> Retriever retrieve = byteRetriever . retrieve' -retrieve' :: Remote -> Key -> (L.ByteString -> Annex ()) -> Annex () +retrieve' :: Remote -> Key -> (L.ByteString -> Annex a) -> Annex a retrieve' r k sink = go =<< glacierEnv c gc u where c = config r diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -1,10 +1,12 @@ {- git-annex chunked remotes - - - Copyright 2014-2020 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Remote.Helper.Chunked ( ChunkSize, ChunkConfig(..), @@ -30,6 +32,7 @@ import Crypto import Backend (isStableKey) import Annex.SpecialRemote.Config +import Annex.Verify import qualified Utility.RawFilePath as R import qualified Data.ByteString as S @@ -250,6 +253,7 @@ :: LensGpgEncParams encc => Retriever -> UUID + -> VerifyConfig -> ChunkConfig -> EncKey -> Key @@ -257,23 +261,27 @@ -> MeterUpdate -> Maybe (Cipher, EncKey) -> encc - -> Annex () -retrieveChunks retriever u chunkconfig encryptor basek dest basep enc encc - | noChunks chunkconfig = + -> Annex Verification +retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc + | noChunks chunkconfig = do -- Optimisation: Try the unchunked key first, to avoid -- looking in the git-annex branch for chunk counts -- that are likely not there. - getunchunked `catchNonAsync` - (\e -> go (Just e) =<< chunkKeysOnly u chunkconfig basek) - | otherwise = go Nothing =<< chunkKeys u chunkconfig basek + tryNonAsync getunchunked >>= \case + Right r -> finalize r + Left e -> go (Just e) + =<< chunkKeysOnly u chunkconfig basek + | otherwise = go Nothing + =<< chunkKeys u chunkconfig basek where go pe cks = do let ls = map chunkKeyList cks currsize <- liftIO $ catchMaybeIO $ getFileSize (toRawFilePath dest) let ls' = maybe ls (setupResume ls) currsize if any null ls' - then noop -- dest is already complete - else firstavail pe currsize ls' + -- dest is already complete + then finalize (Right Nothing) + else finalize =<< firstavail pe currsize ls' firstavail Nothing _ [] = giveup "unable to determine the chunks to use for this remote" firstavail (Just e) _ [] = throwM e @@ -287,35 +295,59 @@ (offsetMeterUpdate basep . toBytesProcessed) offset v <- tryNonAsync $ - retriever (encryptor k) p $ \content -> - bracketIO (maybe opennew openresume offset) hClose $ \h -> do - retrieved (Just h) p content + retriever (encryptor k) p Nothing $ \content -> + bracket (maybe opennew openresume offset) (liftIO . hClose . fst) $ \(h, iv) -> do + retrieved iv (Just h) p content let sz = toBytesProcessed $ fromMaybe 0 $ fromKey keyChunkSize k - getrest p h sz sz ks + getrest p h iv sz sz ks case v of Left e | null ls -> throwM e | otherwise -> firstavail (Just e) currsize ls Right r -> return r - getrest _ _ _ _ [] = noop - getrest p h sz bytesprocessed (k:ks) = do + getrest _ _ iv _ _ [] = return (Right iv) + getrest p h iv sz bytesprocessed (k:ks) = do let p' = offsetMeterUpdate p bytesprocessed liftIO $ p' zeroBytesProcessed - retriever (encryptor k) p' $ retrieved (Just h) p' - getrest p h sz (addBytesProcessed bytesprocessed sz) ks + retriever (encryptor k) p' Nothing $ + retrieved iv (Just h) p' + getrest p h iv sz (addBytesProcessed bytesprocessed sz) ks - getunchunked = retriever (encryptor basek) basep $ retrieved Nothing basep + getunchunked = do + iv <- startVerifyKeyContentIncrementally vc basek + case enc of + Just _ -> do + retriever (encryptor basek) basep Nothing $ + retrieved iv Nothing basep + return (Right iv) + -- Not chunked and not encrypted, so ask the + -- retriever to incrementally verify when it + -- retrieves to a file. It may not finish + -- passing the whole file content to the + -- incremental verifier though. + Nothing -> do + retriever (encryptor basek) basep iv $ + retrieved iv Nothing basep + return $ case iv of + Nothing -> Right iv + Just iv' -> Left (IncompleteVerify iv') - opennew = openBinaryFile dest WriteMode + opennew = do + iv <- startVerifyKeyContentIncrementally vc basek + h <- liftIO $ openBinaryFile dest WriteMode + return (h, iv) -- Open the file and seek to the start point in order to resume. openresume startpoint = do -- ReadWriteMode allows seeking; AppendMode does not. - h <- openBinaryFile dest ReadWriteMode - hSeek h AbsoluteSeek startpoint - return h + h <- liftIO $ openBinaryFile dest ReadWriteMode + liftIO $ hSeek h AbsoluteSeek startpoint + -- No incremental verification when resuming, since that + -- would need to read up to the startpoint. + let iv = Nothing + return (h, iv) {- Progress meter updating is a bit tricky: If the Retriever - populates a file, it is responsible for updating progress @@ -326,18 +358,29 @@ - Instead, writeRetrievedContent is passed a meter to update - as it consumes the ByteString. -} - retrieved h p content = writeRetrievedContent dest enc encc h p' content + retrieved iv h p content = + writeRetrievedContent dest enc encc h p' content iv where p' | isByteContent content = Just p | otherwise = Nothing + + finalize (Right Nothing) = return UnVerified + finalize (Right (Just iv)) = + liftIO (finalizeIncremental iv) >>= \case + Just True -> return Verified + _ -> return UnVerified + finalize (Left v) = return v -{- Writes retrieved file content into the provided Handle, decrypting it +{- Writes retrieved file content to the provided Handle, decrypting it - first if necessary. - - If the remote did not store the content using chunks, no Handle - - will be provided, and it's up to us to open the destination file. + - will be provided, and instead the content will be written to the + - dest file. - + - The IncrementalVerifier is updated as the file content is read. + - - Note that when neither chunking nor encryption is used, and the remote - provides FileContent, that file only needs to be renamed - into place. (And it may even already be in the right place..) @@ -350,8 +393,9 @@ -> Maybe Handle -> Maybe MeterUpdate -> ContentSource + -> Maybe IncrementalVerifier -> Annex () -writeRetrievedContent dest enc encc mh mp content = case (enc, mh, content) of +writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content) of (Nothing, Nothing, FileContent f) | f == dest -> noop | otherwise -> liftIO $ moveFile f dest @@ -371,10 +415,16 @@ (Nothing, _, ByteContent b) -> write b where write b = case mh of - Just h -> liftIO $ b `streamto` h - Nothing -> liftIO $ bracket opendest hClose (b `streamto`) - streamto b h = case mp of - Just p -> meteredWrite p (S.hPut h) b + Just h -> liftIO $ write' b h + Nothing -> liftIO $ bracket opendest hClose (write' b) + write' b h = case mp of + Just p -> + let writer = case miv of + Just iv -> \s -> do + updateIncremental iv s + S.hPut h s + Nothing -> S.hPut h + in meteredWrite p writer b Nothing -> L.hPut h b opendest = openBinaryFile dest WriteMode diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -171,14 +171,14 @@ , lockContent = if versioned then lockContent r else Nothing - , retrieveKeyFile = \k af dest p -> + , retrieveKeyFile = \k af dest p vc -> if isimport - then supportversionedretrieve k af dest p $ + then supportversionedretrieve k af dest p vc $ retrieveKeyFileFromImport dbv ciddbv k af dest p else if isexport - then supportversionedretrieve k af dest p $ + then supportversionedretrieve k af dest p vc $ retrieveKeyFileFromExport dbv k af dest p - else retrieveKeyFile r k af dest p + else retrieveKeyFile r k af dest p vc , retrieveKeyFileCheap = if versioned then retrieveKeyFileCheap r else Nothing @@ -369,9 +369,9 @@ -- versionedExport remotes have a key/value store, so can use -- the usual retrieveKeyFile, rather than an import/export -- variant. However, fall back to that if retrieveKeyFile fails. - supportversionedretrieve k af dest p a + supportversionedretrieve k af dest p vc a | versionedExport (exportActions r) = - retrieveKeyFile r k af dest p + retrieveKeyFile r k af dest p vc `catchNonAsync` const a | otherwise = a diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -34,8 +34,10 @@ addHooks' r starthook stophook = r' where r' = r - { storeKey = \k f p -> wrapper $ storeKey r k f p - , retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p + { storeKey = \k f p -> + wrapper $ storeKey r k f p + , retrieveKeyFile = \k f d p vc -> + wrapper $ retrieveKeyFile r k f d p vc , retrieveKeyFileCheap = case retrieveKeyFileCheap r of Just a -> Just $ \k af f -> wrapper $ a k af f Nothing -> Nothing diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -1,6 +1,6 @@ {- helpers for remotes using http - - - Copyright 2014 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ import Types.StoreRetrieve import Remote.Helper.Special import Utility.Metered +import Utility.Hash (IncrementalVerifier(..)) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -67,9 +68,9 @@ target = toBytesProcessed (numchunks * fromIntegral chunksize) -- Reads the http body and stores it to the specified file, updating the --- meter as it goes. -httpBodyRetriever :: FilePath -> MeterUpdate -> Response BodyReader -> IO () -httpBodyRetriever dest meterupdate resp +-- meter and incremental verifier as it goes. +httpBodyRetriever :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Response BodyReader -> IO () +httpBodyRetriever dest meterupdate iv resp | responseStatus resp /= ok200 = giveup $ show $ responseStatus resp | otherwise = bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed) where @@ -82,4 +83,5 @@ let sofar' = addBytesProcessed sofar $ S.length b S.hPut h b meterupdate sofar' + maybe noop (flip updateIncremental b) iv go sofar' h diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -40,8 +40,8 @@ Just False -> giveup "Transfer failed" Nothing -> remoteUnavail -retrieve :: VerifyConfig -> (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -retrieve verifyconfig runner k af dest p = do +retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieve runner k af dest p verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k metered (Just p) k $ \m p' -> runner p' (P2P.get dest k iv af m p') >>= \case diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -1,10 +1,11 @@ {- helpers for special remotes - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module Remote.Helper.Special ( @@ -19,6 +20,7 @@ fileStorer, byteStorer, fileRetriever, + fileRetriever', byteRetriever, storeKeyDummy, retrieveKeyFileDummy, @@ -38,6 +40,7 @@ import Annex.SpecialRemote.Config import Types.StoreRetrieve import Types.Remote +import Annex.Verify import Annex.UUID import Config import Config.Cost @@ -53,6 +56,8 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as M +import Control.Concurrent.STM +import Control.Concurrent.Async {- Special remotes don't have a configured url, so Git.Repo does not - automatically generate remotes for them. This looks for a different @@ -68,13 +73,13 @@ (pure Git.Construct.fromUnknown) match (ConfigKey k) _ = "remote." `S.isPrefixOf` k - && (".annex-" <> encodeBS' s) `S.isSuffixOf` k + && (".annex-" <> encodeBS s) `S.isSuffixOf` k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex () gitConfigSpecialRemote u c cfgs = do forM_ cfgs $ \(k, v) -> - setConfig (remoteAnnexConfig c (encodeBS' k)) v + setConfig (remoteAnnexConfig c (encodeBS k)) v storeUUIDIn (remoteAnnexConfig c "uuid") u -- RetrievalVerifiableKeysSecure unless overridden by git config. @@ -100,20 +105,40 @@ byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex ()) -> Storer byteStorer a k c m = withBytes c $ \b -> a k b m --- A Retriever that writes the content of a Key to a provided file. --- It is responsible for updating the progress meter as it retrieves data. -fileRetriever :: (FilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever -fileRetriever a k m callback = do - f <- prepTmp k - a (fromRawFilePath f) k m - pruneTmpWorkDirBefore f (callback . FileContent . fromRawFilePath) - -- A Retriever that generates a lazy ByteString containing the Key's -- content, and passes it to a callback action which will fully consume it -- before returning. -byteRetriever :: (Key -> (L.ByteString -> Annex ()) -> Annex ()) -> Retriever -byteRetriever a k _m callback = a k (callback . ByteContent) +byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a +byteRetriever a k _m _miv callback = a k (callback . ByteContent) +-- A Retriever that writes the content of a Key to a provided file. +-- The action is responsible for updating the progress meter as it +-- retrieves data. The incremental verifier is updated in the background as +-- the action writes to the file, but may not be updated with the entire +-- content of the file. +fileRetriever :: (RawFilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever +fileRetriever a = fileRetriever' $ \f k m miv -> do + let retrieve = a f k m + case miv of + Nothing -> retrieve + Just iv -> do + finished <- liftIO newEmptyTMVarIO + t <- liftIO $ async $ tailVerify iv f finished + let finishtail = do + liftIO $ atomically $ putTMVar finished () + liftIO (wait t) + retrieve `finally` finishtail + +{- A Retriever that writes the content of a Key to a provided file. + - The action is responsible for updating the progress meter and the + - incremental verifier as it retrieves data. + -} +fileRetriever' :: (RawFilePath -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()) -> Retriever +fileRetriever' a k m miv callback = do + f <- prepTmp k + a f k m miv + pruneTmpWorkDirBefore f (callback . FileContent . fromRawFilePath) + {- The base Remote that is provided to specialRemote needs to have - storeKey, retrieveKeyFile, removeKey, and checkPresent methods, - but they are never actually used (since specialRemote replaces them). @@ -121,8 +146,8 @@ -} storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex () storeKeyDummy _ _ _ = error "missing storeKey implementation" -retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -retrieveKeyFileDummy _ _ _ _ = error "missing retrieveKeyFile implementation" +retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation" removeKeyDummy :: Key -> Annex () removeKeyDummy _ = error "missing removeKey implementation" checkPresentDummy :: Key -> Annex Bool @@ -167,7 +192,7 @@ where encr = baser { storeKey = \k _f p -> cip >>= storeKeyGen k p - , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p + , retrieveKeyFile = \k _f d p vc -> cip >>= retrieveKeyFileGen k d p vc , retrieveKeyFileCheap = case retrieveKeyFileCheap baser of Nothing -> Nothing Just a @@ -216,11 +241,10 @@ enck = maybe id snd enc -- call retriever to get chunks; decrypt them; stream to dest file - retrieveKeyFileGen k dest p enc = do + retrieveKeyFileGen k dest p vc enc = displayprogress p k Nothing $ \p' -> - retrieveChunks retriever (uuid baser) chunkconfig - enck k dest p' enc encr - return UnVerified + retrieveChunks retriever (uuid baser) vc + chunkconfig enck k dest p' enc encr where enck = maybe id snd enc diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Remote.Hook (remote) where import Annex.Common @@ -131,8 +133,8 @@ else return $ Just fallback else return $ Just command where - hook = annexConfig $ encodeBS' $ hookname ++ "-" ++ action ++ "-hook" - hookfallback = annexConfig $ encodeBS' $ hookname ++ "-hook" + hook = annexConfig $ encodeBS $ hookname ++ "-" ++ action ++ "-hook" + hookfallback = annexConfig $ encodeBS $ hookname ++ "-hook" runHook :: HookName -> Action -> Key -> Maybe FilePath -> Annex () runHook hook action k f = lookupHook hook action >>= \case @@ -160,7 +162,7 @@ retrieve :: HookName -> Retriever retrieve h = fileRetriever $ \d k _p -> - unlessM (runHook' h "retrieve" k (Just d) $ return True) $ + unlessM (runHook' h "retrieve" k (Just (fromRawFilePath d)) $ return True) $ giveup "failed to retrieve content" remove :: HookName -> Remover diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -1,6 +1,6 @@ {- HttpAlso remote (readonly). - - - Copyright 2020 Joey Hess + - Copyright 2020-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,6 +20,7 @@ import Creds import Messages.Progress import Utility.Metered +import Annex.Verify import qualified Annex.Url as Url import Annex.SpecialRemote.Config @@ -113,20 +114,21 @@ gitConfigSpecialRemote u c' [("httpalso", "true")] return (c', u) -downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -downloadKey baseurl ll key _af dest p = do - downloadAction dest p key (keyUrlAction baseurl ll key) - return UnVerified +downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey baseurl ll key _af dest p vc = do + iv <- startVerifyKeyContentIncrementally vc key + downloadAction dest p iv key (keyUrlAction baseurl ll key) + snd <$> finishVerifyKeyContentIncrementally iv retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () retriveExportHttpAlso baseurl key loc dest p = - downloadAction dest p key (exportLocationUrlAction baseurl loc) + downloadAction dest p Nothing key (exportLocationUrlAction baseurl loc) -downloadAction :: FilePath -> MeterUpdate -> Key -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () -downloadAction dest p key run = +downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Key -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () +downloadAction dest p iv key run = Url.withUrlOptions $ \uo -> meteredFile dest (Just p) key $ - run (\url -> Url.download' p url dest uo) + run (\url -> Url.download' p iv url dest uo) >>= either giveup (const (return ())) checkKey :: Maybe URLString -> LearnedLayout -> Key -> Annex Bool diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -13,7 +13,6 @@ import Annex.Common import qualified Annex import qualified P2P.Protocol as P2P -import qualified Annex.Content import P2P.Address import P2P.Annex import P2P.IO @@ -57,7 +56,7 @@ , cost = cst , name = Git.repoDescribe r , storeKey = store (const protorunner) - , retrieveKeyFile = retrieve (Annex.Content.RemoteVerify this) (const protorunner) + , retrieveKeyFile = retrieve (const protorunner) , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove protorunner diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -76,10 +76,7 @@ fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc let o = genRsyncOpts c gc transport url let islocal = rsyncUrlIsPath $ rsyncUrl o - let specialcfg = (specialRemoteCfg c) - -- Rsync displays its own progress. - { displayProgress = False } - return $ Just $ specialRemote' specialcfg c + return $ Just $ specialRemote c (fileStorer $ store o) (fileRetriever $ retrieve o) (remove o) @@ -238,8 +235,8 @@ ] else return False -retrieve :: RsyncOpts -> FilePath -> Key -> MeterUpdate -> Annex () -retrieve o f k p = rsyncRetrieveKey o k f (Just p) +retrieve :: RsyncOpts -> RawFilePath -> Key -> MeterUpdate -> Annex () +retrieve o f k p = rsyncRetrieveKey o k (fromRawFilePath f) (Just p) retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex () retrieveCheap o k _af f = ifM (preseedTmp k f) @@ -381,13 +378,12 @@ rsyncRemote :: Direction -> RsyncOpts -> Maybe MeterUpdate -> [CommandParam] -> Annex Bool rsyncRemote direction o m params = do - showOutput -- make way for progress bar opts <- mkopts let ps = opts ++ Param "--progress" : params case m of Nothing -> liftIO $ rsync ps Just meter -> do - oh <- mkOutputHandler + oh <- mkOutputHandlerQuiet liftIO $ rsyncProgress oh meter ps where mkopts diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Remote.S3 (remote, iaHost, configIA, iaItemUrl) where @@ -59,6 +60,7 @@ import Types.ProposedAccepted import Types.NumCopies import Utility.Metered +import Utility.Hash (IncrementalVerifier) import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url @@ -400,32 +402,32 @@ - out to the file. Would be better to implement a byteRetriever, but - that is difficult. -} retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever -retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case +retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case (Just h) -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Left failreason -> do warning failreason giveup "cannot download content" - Right loc -> retrieveHelper info h loc f p + Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv Nothing -> getPublicWebUrls' (uuid r) rs info c k >>= \case Left failreason -> do warning failreason giveup "cannot download content" - Right us -> unlessM (withUrlOptions $ downloadUrl k p us f) $ + Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $ giveup "failed to download content" -retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex () -retrieveHelper info h loc f p = retrieveHelper' h f p $ +retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () +retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $ case loc of Left o -> S3.getObject (bucket info) o Right (S3VersionID o vid) -> (S3.getObject (bucket info) o) { S3.goVersionId = Just vid } -retrieveHelper' :: S3Handle -> FilePath -> MeterUpdate -> S3.GetObject -> Annex () -retrieveHelper' h f p req = liftIO $ runResourceT $ do +retrieveHelper' :: S3Handle -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex () +retrieveHelper' h f p iv req = liftIO $ runResourceT $ do S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req - Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp + Url.sinkResponseFile p iv zeroBytesProcessed f WriteMode rsp remove :: S3HandleVar -> Remote -> S3Info -> Remover remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> do @@ -496,11 +498,11 @@ retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () retrieveExportS3 hv r info _k loc f p = do withS3Handle hv $ \case - Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p + Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p Nothing Nothing -> case getPublicUrlMaker info of Just geturl -> either giveup return =<< Url.withUrlOptions - (Url.download' p (geturl exportloc) f) + (Url.download' p Nothing (geturl exportloc) f) Nothing -> giveup $ needS3Creds (uuid r) where exportloc = bucketExportLocation info loc @@ -648,7 +650,7 @@ retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest mkkey p = withS3Handle hv $ \case Just h -> do - rewritePreconditionException $ retrieveHelper' h dest p $ + rewritePreconditionException $ retrieveHelper' h dest p Nothing $ limitGetToContentIdentifier cid $ S3.getObject (bucket info) o k <- mkkey diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -144,8 +144,8 @@ (giveup "tahoe failed to store content") (\cap -> storeCapability rs k cap) -retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -retrieve rs hdl k _f d _p = do +retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieve rs hdl k _f d _p _ = do go =<< getCapability rs k -- Tahoe verifies the content it retrieves using cryptographically -- secure methods. diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -1,6 +1,6 @@ {- Web remote. - - - Copyright 2011 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ import qualified Git import qualified Git.Construct import Annex.Content +import Annex.Verify import Config.Cost import Config import Logs.Web @@ -81,20 +82,34 @@ , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification -downloadKey key _af dest p = do - get =<< getWebUrls key - return UnVerified +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey key _af dest p vc = go =<< getWebUrls key where - get [] = giveup "no known url" - get urls = do - r <- untilTrue urls $ \u -> do - let (u', downloader) = getDownloader u - case downloader of - YoutubeDownloader -> youtubeDlTo key u' dest p - _ -> Url.withUrlOptions $ downloadUrl key p [u'] dest - unless r $ - giveup "download failed" + go [] = giveup "no known url" + go urls = dl (partition (not . isyoutube) (map getDownloader urls)) >>= \case + Just v -> return v + Nothing -> giveup $ unwords + [ "downloading from all" + , show (length urls) + , "known url(s) failed" + ] + + dl ([], ytus) = flip getM (map fst ytus) $ \u -> + ifM (youtubeDlTo key u dest p) + ( return (Just UnVerified) + , return Nothing + ) + dl (us, ytus) = do + iv <- startVerifyKeyContentIncrementally vc key + ifM (Url.withUrlOptions $ downloadUrl True key p iv (map fst us) dest) + ( finishVerifyKeyContentIncrementally iv >>= \case + (True, v) -> return (Just v) + (False, _) -> dl ([], ytus) + , dl ([], ytus) + ) + + isyoutube (_, YoutubeDownloader) = True + isyoutube _ = False uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () uploadKey _ _ _ = giveup "upload to web not supported" diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -1,12 +1,13 @@ {- WebDAV remotes. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Remote.WebDAV (remote, davCreds, configUrl) where @@ -39,6 +40,7 @@ import Creds import Utility.Metered import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionContent) +import Utility.Hash (IncrementalVerifier(..)) import Annex.UUID import Remote.WebDAV.DavLocation import Types.ProposedAccepted @@ -167,17 +169,20 @@ moveDAV (baseURL dav) tmp dest retrieve :: DavHandleVar -> ChunkConfig -> Retriever -retrieve hv cc = fileRetriever $ \d k p -> +retrieve hv cc = fileRetriever' $ \d k p iv -> withDavHandle hv $ \dav -> case cc of - LegacyChunks _ -> retrieveLegacyChunked d k p dav - _ -> liftIO $ - goDAV dav $ retrieveHelper (keyLocation k) d p + LegacyChunks _ -> do + -- Not doing incremental verification for chunks. + liftIO $ maybe noop unableIncremental iv + retrieveLegacyChunked (fromRawFilePath d) k p dav + _ -> liftIO $ goDAV dav $ + retrieveHelper (keyLocation k) (fromRawFilePath d) p iv -retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO () -retrieveHelper loc d p = do +retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> DAVT IO () +retrieveHelper loc d p iv = do debugDav $ "retrieve " ++ loc inLocation loc $ - withContentM $ httpBodyRetriever d p + withContentM $ httpBodyRetriever d p iv remove :: DavHandleVar -> Remover remove hv k = withDavHandle hv $ \dav -> liftIO $ goDAV dav $ @@ -216,7 +221,7 @@ retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () retrieveExportDav hdl _k loc d p = case exportLocation loc of Right src -> withDavHandle hdl $ \h -> runExport h $ \_dav -> - retrieveHelper src d p + retrieveHelper src d p Nothing Left err -> giveup err checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -75,6 +75,7 @@ import qualified Utility.Format import qualified Utility.Verifiable import qualified Utility.Process +import qualified Utility.Process.Transcript import qualified Utility.Misc import qualified Utility.InodeCache import qualified Utility.Env @@ -309,6 +310,7 @@ unitTests note = testGroup ("Unit Tests " ++ note) [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras + , testCase "readonly" test_readonly , testCase "ignore deleted files" test_ignore_deleted_files , testCase "metadata" test_metadata , testCase "export_import" test_export_import @@ -427,6 +429,29 @@ annexed_present wormannexedfile checkbackend wormannexedfile backendWORM +test_readonly :: Assertion +test_readonly = +#ifndef mingw32_HOST_OS + withtmpclonerepo $ \r1 -> + withtmpclonerepo $ \r2 -> do + pair r1 r2 + indir r1 $ do + git_annex "get" [annexedfile] "get failed in first repo" + {- chmod may fail, or not be available, or the + - filesystem not support permissions. -} + void $ Utility.Process.Transcript.processTranscript + "chmod" ["-R", "-w", r1] Nothing + indir r2 $ do + git_annex "sync" ["r1", "--no-push"] "sync with readonly repo" + git_annex "get" [annexedfile, "--from", "r1"] "get from readonly repo" + git "remote" ["rm", "origin"] "remote rm" + git_annex "drop" [annexedfile] "drop vs readonly repo" +#else + -- This test does not work on Windows, and it doesn't make sense to + -- try to support this on Windows anyway. + return () +#endif + test_ignore_deleted_files :: Assertion test_ignore_deleted_files = intmpclonerepo $ do git_annex "get" [annexedfile] "get" @@ -1639,14 +1664,6 @@ git_annex "sync" [] "sync" git "checkout" [origbranch] "git checkout" doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") - -{- Set up repos as remotes of each other. -} -pair :: FilePath -> FilePath -> Assertion -pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do - when (r /= r1) $ - git "remote" ["add", "r1", "../../" ++ r1] "remote add" - when (r /= r2) $ - git "remote" ["add", "r2", "../../" ++ r2] "remote add" test_map :: Assertion test_map = intmpclonerepo $ do diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -108,7 +108,7 @@ with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do - let k = Git.Types.ConfigKey (encodeBS' config) + let k = Git.Types.ConfigKey (encodeBS config) let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) @@ -631,3 +631,12 @@ origBranch = maybe "foo" (Git.Types.fromRef . Git.Ref.base . Annex.AdjustedBranch.fromAdjustedBranch) <$> Annex.inRepo Git.Branch.current + +{- Set up repos as remotes of each other. -} +pair :: FilePath -> FilePath -> Assertion +pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do + when (r /= r1) $ + git "remote" ["add", "r1", "../../" ++ r1] "remote add" + when (r /= r2) $ + git "remote" ["add", "r2", "../../" ++ r2] "remote add" + diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -15,6 +15,7 @@ RemoteGitConfig(..), Remote, RemoteType, + VerifyConfig, ) where import Annex @@ -27,3 +28,4 @@ type Backend = BackendA Annex type Remote = RemoteA Annex type RemoteType = RemoteTypeA Annex +type VerifyConfig = VerifyConfigA Annex diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -65,7 +65,7 @@ actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ ActionItemAssociatedFile (associatedFile i) (transferKey t) actionItemDesc (ActionItemTreeFile f) = f -actionItemDesc (ActionItemOther s) = encodeBS' (fromMaybe "" s) +actionItemDesc (ActionItemOther s) = encodeBS (fromMaybe "" s) actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai actionItemKey :: ActionItem -> Maybe Key diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -13,8 +13,7 @@ import Types.KeySource import Utility.Metered import Utility.FileSystemEncoding - -import Data.ByteString (ByteString) +import Utility.Hash (IncrementalVerifier) data BackendA a = Backend { backendVariety :: KeyVariety @@ -43,11 +42,3 @@ instance Eq (BackendA a) where a == b = backendVariety a == backendVariety b - -data IncrementalVerifier = IncrementalVerifier - { updateIncremental :: ByteString -> IO () - -- ^ Called repeatedly on each peice of the content. - , finalizeIncremental :: IO Bool - -- ^ Called once the full content has been sent, returns true - -- if the hash verified. - } diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -95,6 +95,7 @@ , annexDebugFilter :: Maybe String , annexWebOptions :: [String] , annexYoutubeDlOptions :: [String] + , annexYoutubeDlCommand :: Maybe String , annexAriaTorrentOptions :: [String] , annexCrippledFileSystem :: Bool , annexLargeFiles :: GlobalConfigurable (Maybe String) @@ -180,6 +181,7 @@ , annexDebugFilter = getmaybe (annexConfig "debugfilter") , annexWebOptions = getwords (annexConfig "web-options") , annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options") + , annexYoutubeDlCommand = getmaybe (annexConfig "youtube-dl-command") , annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options") , annexCrippledFileSystem = getbool (annexConfig "crippledfilesystem") False , annexLargeFiles = configurable Nothing $ @@ -476,4 +478,4 @@ {- A per-remote setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig r key = ConfigKey $ - "remote." <> encodeBS' (getRemoteName r) <> "." <> key + "remote." <> encodeBS (getRemoteName r) <> "." <> key diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -16,6 +16,7 @@ , RemoteStateHandle , SetupStage(..) , Availability(..) + , VerifyConfigA(..) , Verification(..) , unVerified , RetrievalSecurityPolicy(..) @@ -41,6 +42,7 @@ import Types.Export import Types.Import import Types.RemoteConfig +import Utility.Hash (IncrementalVerifier) import Config.Cost import Utility.Metered import Git.Types (RemoteName) @@ -94,7 +96,7 @@ -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) -- Throws exception on failure. - , retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a Verification + , retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfigA a -> a Verification -- Retrieves a key's contents to a tmp file, if it can be done cheaply. -- It's ok to create a symlink or hardlink. -- Throws exception on failure. @@ -191,6 +193,12 @@ instance ToUUID (RemoteA a) where toUUID = uuid +data VerifyConfigA a + = AlwaysVerify + | NoVerify + | RemoteVerify (RemoteA a) + | DefaultVerify + data Verification = UnVerified -- ^ Content was not verified during transfer, but is probably @@ -203,7 +211,9 @@ | MustVerify -- ^ Content likely to have been altered during transfer, -- verify even if verification is normally disabled - deriving (Show) + | IncompleteVerify IncrementalVerifier + -- ^ Content was partially verified during transfer, but + -- the verification is not complete. unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -1,14 +1,17 @@ {- Types for Storer and Retriever actions for remotes. - - - Copyright 2014 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Types.StoreRetrieve where import Annex.Common import Utility.Metered +import Utility.Hash (IncrementalVerifier) import qualified Data.ByteString.Lazy as L @@ -27,8 +30,17 @@ -- Action that retrieves a Key's content from a remote, passing it to a -- callback, which will fully consume the content before returning. +-- -- Throws exception if key is not present, or remote is not accessible. -type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex ()) -> Annex () +-- +-- When it retrieves FileContent, it is responsible for updating the +-- MeterUpdate. And when the IncrementalVerifier is passed to it, +-- and it retrieves FileContent, it can feed some or all of the file's +-- content to the verifier before running the callback. +-- This should not be done when it retrieves ByteContent. +type Retriever = forall a. + Key -> MeterUpdate -> Maybe IncrementalVerifier + -> (ContentSource -> Annex a) -> Annex a -- Action that removes a Key's content from a remote. -- Succeeds if key is already not present. diff --git a/Types/UUID.hs b/Types/UUID.hs --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -48,10 +48,10 @@ | otherwise = UUID b instance FromUUID String where - fromUUID s = decodeBS' (fromUUID s) + fromUUID s = decodeBS (fromUUID s) instance ToUUID String where - toUUID s = toUUID (encodeBS' s) + toUUID s = toUUID (encodeBS s) instance FromUUID ConfigValue where fromUUID s = (ConfigValue (fromUUID s)) diff --git a/Types/VectorClock.hs b/Types/VectorClock.hs --- a/Types/VectorClock.hs +++ b/Types/VectorClock.hs @@ -1,9 +1,6 @@ {- git-annex vector clocks - - - We don't have a way yet to keep true distributed vector clocks. - - The next best thing is a timestamp. - - - - Copyright 2017-2020 Joey Hess + - Copyright 2017-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,6 +17,11 @@ -- Unknown is used for those. data VectorClock = Unknown | VectorClock POSIXTime deriving (Eq, Ord, Show) + +-- | This is a candidate value to use in a VectorClock. It +-- may not be suitable to use this, when a previously used VectorClock +-- is the same or higher. +data CandidateVectorClock = CandidateVectorClock POSIXTime -- Unknown is oldest. prop_VectorClock_sane :: Bool diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -93,7 +93,7 @@ push :: Annex () push = do origin_master <- inRepo $ Git.Ref.exists $ - Git.Ref $ encodeBS' "origin/master" + Git.Ref $ encodeBS "origin/master" origin_gitannex <- Annex.Branch.hasOrigin case (origin_master, origin_gitannex) of (_, True) -> do diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -60,7 +60,7 @@ fromDirectBranch :: Ref -> Ref fromDirectBranch directhead = case splitc '/' $ fromRef directhead of ("refs":"heads":"annex":"direct":rest) -> - Ref $ encodeBS' $ "refs/heads/" ++ intercalate "/" rest + Ref $ encodeBS $ "refs/heads/" ++ intercalate "/" rest _ -> directhead switchHEADBack :: Annex () diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -1,6 +1,6 @@ {- file copying - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - License: BSD-2-clause -} @@ -30,6 +30,12 @@ , Param "-p") , (not allmeta && BuildInfo.cp_preserve_timestamps , Param "--preserve=timestamps") + -- cp -a may preserve xattrs that have special meaning, + -- eg to NFS, and have even been observed to prevent later + -- changing the permissions of the file. So prevent preserving + -- xattrs. + , (allmeta && BuildInfo.cp_a && BuildInfo.cp_no_preserve_xattr_supported + , Param "--no-preserve=xattr") ] where allmeta = meta == CopyAllMetaData diff --git a/Utility/Data.hs b/Utility/Data.hs --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013-2021 Joey Hess - - License: BSD-2-clause -} @@ -10,8 +10,12 @@ module Utility.Data ( firstJust, eitherToMaybe, + s2w8, + w82s, ) where +import Data.Word + {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a firstJust ms = case dropWhile (== Nothing) ms of @@ -20,3 +24,15 @@ eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c diff --git a/Utility/Debug.hs b/Utility/Debug.hs --- a/Utility/Debug.hs +++ b/Utility/Debug.hs @@ -34,7 +34,7 @@ deriving (Eq, Show) instance IsString DebugSource where - fromString = DebugSource . encodeBS' + fromString = DebugSource . encodeBS -- | Selects whether to display a message from a source. data DebugSelector @@ -97,6 +97,6 @@ formatDebugMessage :: DebugSource -> String -> IO S.ByteString formatDebugMessage (DebugSource src) msg = do - t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]" + t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]" <$> getZonedTime return (t <> " (" <> src <> ") " <> encodeBS msg) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -11,7 +11,6 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding, - withFilePath, RawFilePath, fromRawFilePath, toRawFilePath, @@ -19,36 +18,22 @@ encodeBL, decodeBS, encodeBS, - decodeBL', - encodeBL', - decodeBS', - encodeBS', truncateFilePath, - s2w8, - w82s, - c2w8, - w82c, ) where import qualified GHC.Foreign as GHC import qualified GHC.IO.Encoding as Encoding -import Foreign.C import System.IO import System.IO.Unsafe -import Data.Word import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafePackMallocCStringLen) #ifdef mingw32_HOST_OS import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 -#else -import Data.List -import Utility.Split #endif -import Utility.Exception - {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current - locale. @@ -81,40 +66,10 @@ fileEncoding h = hSetEncoding h Encoding.utf8 #endif -{- Marshal a Haskell FilePath into a NUL terminated C string using temporary - - storage. The FilePath is encoded using the filesystem encoding, - - reversing the decoding that should have been done when the FilePath - - was obtained. -} -withFilePath :: FilePath -> (CString -> IO a) -> IO a -withFilePath fp f = Encoding.getFileSystemEncoding - >>= \enc -> GHC.withCString enc fp f - -{- Encodes a FilePath into a String, applying the filesystem encoding. - - - - There are very few things it makes sense to do with such an encoded - - string. It's not a legal filename; it should not be displayed. - - So this function is not exported, but instead used by the few functions - - that can usefully consume it. - - - - This use of unsafePerformIO is belived to be safe; GHC's interface - - only allows doing this conversion with CStrings, and the CString buffer - - is allocated, used, and deallocated within the call, with no side - - effects. - - - - If the FilePath contains a value that is not legal in the filesystem - - encoding, rather than thowing an exception, it will be returned as-is. - -} -{-# NOINLINE _encodeFilePath #-} -_encodeFilePath :: FilePath -> String -_encodeFilePath fp = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString enc fp (GHC.peekCString Encoding.char8) - `catchNonAsync` (\_ -> return fp) - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBL = encodeW8NUL . L.unpack +decodeBL = decodeBS . L.toStrict #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} @@ -124,104 +79,45 @@ {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS -encodeBL = L.pack . decodeW8NUL +encodeBL = L.fromStrict . encodeBS #else encodeBL = L8.fromString #endif decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . S.unpack +-- This is a copy of code from System.FilePath.Internal.decodeFilePath. +-- However, older versions of that library truncated at NUL, which this +-- must not do, because it may end up used on something other than a unix +-- filepath. +{-# NOINLINE decodeBS #-} +decodeBS b = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + S.useAsCStringLen b (GHC.peekCStringLen enc) #else decodeBS = S8.toString #endif encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS -encodeBS = S.pack . decodeW8NUL +-- This is a copy of code from System.FilePath.Internal.encodeFilePath. +-- However, older versions of that library truncated at NUL, which this +-- must not do, because it may end up used on something other than a unix +-- filepath. +{-# NOINLINE encodeBS #-} +encodeBS f = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + GHC.newCStringLen enc f >>= unsafePackMallocCStringLen #else encodeBS = S8.fromString #endif -{- Faster version that assumes the string does not contain NUL; - - if it does it will be truncated before the NUL. -} -decodeBS' :: S.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBS' = encodeW8 . S.unpack -#else -decodeBS' = S8.toString -#endif - -encodeBS' :: FilePath -> S.ByteString -#ifndef mingw32_HOST_OS -encodeBS' = S.pack . decodeW8 -#else -encodeBS' = S8.fromString -#endif - -decodeBL' :: L.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBL' = encodeW8 . L.unpack -#else -decodeBL' = L8.toString -#endif - -encodeBL' :: FilePath -> L.ByteString -#ifndef mingw32_HOST_OS -encodeBL' = L.pack . decodeW8 -#else -encodeBL' = L8.fromString -#endif - fromRawFilePath :: RawFilePath -> FilePath fromRawFilePath = decodeFilePath toRawFilePath :: FilePath -> RawFilePath toRawFilePath = encodeFilePath -#ifndef mingw32_HOST_OS -{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - - - w82s produces a String, which may contain Chars that are invalid - - unicode. From there, this is really a simple matter of applying the - - file system encoding, only complicated by GHC's interface to doing so. - - - - Note that the encoding stops at any NUL in the input. FilePaths - - cannot contain embedded NUL, but Haskell Strings may. - -} -{-# NOINLINE encodeW8 #-} -encodeW8 :: [Word8] -> FilePath -encodeW8 w8 = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc - -decodeW8 :: FilePath -> [Word8] -decodeW8 = s2w8 . _encodeFilePath - -{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} -encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) - where - nul = '\NUL' - -decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul - where - nul = '\NUL' -#endif - -c2w8 :: Char -> Word8 -c2w8 = fromIntegral . fromEnum - -w82c :: Word8 -> Char -w82c = toEnum . fromIntegral - -s2w8 :: String -> [Word8] -s2w8 = map c2w8 - -w82s :: [Word8] -> String -w82s = map w82c - {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. - @@ -233,8 +129,8 @@ truncateFilePath n = go . reverse where go f = - let bytes = decodeW8 f - in if length bytes <= n + let b = encodeBS f + in if S.length b <= n then reverse f else go (drop 1 f) #else diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -1,5 +1,12 @@ -{- Convenience wrapper around cryptonite's hashing. -} +{- Convenience wrapper around cryptonite's hashing. + - + - Copyright 2013-2021 Joey Hess + - + - License: BSD-2-clause + -} +{-# LANGUAGE BangPatterns #-} + module Utility.Hash ( sha1, sha1_context, @@ -57,12 +64,15 @@ Mac(..), calcMac, props_macs_stable, + IncrementalVerifier(..), + mkIncrementalVerifier, ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.IORef import "cryptonite" Crypto.MAC.HMAC hiding (Context) import "cryptonite" Crypto.Hash @@ -237,10 +247,6 @@ where foo = L.fromChunks [T.encodeUtf8 $ T.pack "foo"] -{- File names are (client-side) MAC'ed on special remotes. - - The chosen MAC algorithm needs to be same for all files stored on the - - remote. - -} data Mac = HmacSha1 | HmacSha224 | HmacSha256 | HmacSha384 | HmacSha512 deriving (Eq) @@ -273,3 +279,45 @@ where key = T.encodeUtf8 $ T.pack "foo" msg = T.encodeUtf8 $ T.pack "bar" + +data IncrementalVerifier = IncrementalVerifier + { updateIncremental :: S.ByteString -> IO () + -- ^ Called repeatedly on each peice of the content. + , finalizeIncremental :: IO (Maybe Bool) + -- ^ Called once the full content has been sent, returns True + -- if the hash verified, False if it did not, and Nothing if + -- incremental verification was unable to be done. + , unableIncremental :: IO () + -- ^ Call if the incremental verification is unable to be done. + , positionIncremental :: IO (Maybe Integer) + -- ^ Returns the number of bytes that have been fed to this + -- incremental verifier so far. (Nothing if unableIncremental was + -- called.) + , descVerify :: String + -- ^ A description of what is done to verify the content. + } + +mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier +mkIncrementalVerifier ctx descverify samechecksum = do + v <- newIORef (Just (ctx, 0)) + return $ IncrementalVerifier + { updateIncremental = \b -> + modifyIORef' v $ \case + (Just (ctx', n)) -> + let !ctx'' = hashUpdate ctx' b + !n' = n + fromIntegral (S.length b) + in (Just (ctx'', n')) + Nothing -> Nothing + , finalizeIncremental = + readIORef v >>= \case + (Just (ctx', _)) -> do + let digest = hashFinalize ctx' + return $ Just $ + samechecksum (show digest) + Nothing -> return Nothing + , unableIncremental = writeIORef v Nothing + , positionIncremental = readIORef v >>= \case + Just (_, n) -> return (Just n) + Nothing -> return Nothing + , descVerify = descverify + } diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -33,6 +33,7 @@ import Utility.FileSystemEncoding import Utility.Env import Utility.Env.Set +import Utility.Tmp import qualified Utility.LockFile.Posix as Posix import System.IO @@ -143,7 +144,7 @@ where go abslockfile sidelock = do let abslockfile' = fromRawFilePath abslockfile - (tmp, h) <- openTempFile (takeDirectory abslockfile') "locktmp" + (tmp, h) <- openTmpFileIn (takeDirectory abslockfile') "locktmp" let tmp' = toRawFilePath tmp setFileMode tmp' (combineModes readModes) hPutStr h . show =<< mkPidLock diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -187,7 +187,13 @@ dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common #ifdef mingw32_HOST_OS - normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive + normdrive = map toLower + -- Get just the drive letter, removing any leading + -- path separator, which takeDrive leaves on the drive + -- letter. + . dropWhileEnd (isPathSeparator . fromIntegral . ord) + . fromRawFilePath + . takeDrive #endif {- Checks if a command is available in PATH. diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -14,6 +14,7 @@ withTmpFile, withTmpFileIn, relatedTemplate, + openTmpFileIn, ) where import System.IO @@ -21,6 +22,7 @@ import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files hiding (removeLink) +import System.IO.Error import Utility.Exception import Utility.FileSystemEncoding @@ -28,6 +30,18 @@ type Template = String +{- This is the same as openTempFile, except when there is an + - error, it displays the template as well as the directory, + - to help identify what call was responsible. + -} +openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle) +openTmpFileIn dir template = openTempFile dir template + `catchIO` decoraterrror + where + decoraterrror e = throwM $ + let loc = ioeGetLocation e ++ " template " ++ template + in annotateIOError e loc Nothing Nothing + {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. @@ -43,7 +57,7 @@ template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir - openTempFile dir template + openTmpFileIn dir template cleanup (tmpfile, h) = do _ <- tryIO $ hClose h tryIO $ removeFile tmpfile @@ -73,7 +87,7 @@ withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = liftIO $ openTempFile tmpdir template + create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h catchBoolIO (removeFile name >> return True) diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -1,6 +1,6 @@ {- Url downloading. - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - License: BSD-2-clause -} @@ -53,6 +53,7 @@ #endif import Utility.IPAddress import qualified Utility.RawFilePath as R +import Utility.Hash (IncrementalVerifier(..)) import Network.URI import Network.HTTP.Types @@ -363,11 +364,11 @@ - - When the download fails, returns an error message. -} -download :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) +download :: MeterUpdate -> Maybe IncrementalVerifier -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) download = download' False -download' :: Bool -> MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) -download' nocurlerror meterupdate url file uo = +download' :: Bool -> MeterUpdate -> Maybe IncrementalVerifier -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) +download' nocurlerror meterupdate iv url file uo = catchJust matchHttpException go showhttpexception `catchNonAsync` (dlfailed . show) where @@ -376,7 +377,7 @@ case (urlDownloader uo, parseRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (matchStatusCodeException (== found302)) - (downloadConduit meterupdate req file uo >> return (Right ())) + (downloadConduit meterupdate iv req file uo >> return (Right ())) (followredir r) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) | isfileurl u -> downloadfile u @@ -404,7 +405,9 @@ HttpExceptionRequest _ other -> show other _ -> show he - dlfailed msg = return $ Left $ "download failed: " ++ msg + dlfailed msg = do + noverification + return $ Left $ "download failed: " ++ msg basecurlparams = curlParams uo [ if nocurlerror @@ -416,6 +419,7 @@ ] downloadcurl rawurl curlparams = do + noverification -- curl does not create destination file -- if the url happens to be empty, so pre-create. unlessM (doesFileExist file) $ @@ -429,6 +433,7 @@ downloadcurl rawurl =<< curlRestrictedParams r u defport basecurlparams downloadfile u = do + noverification let src = unEscapeString (uriPath u) withMeteredFile src meterupdate $ L.writeFile file @@ -446,6 +451,8 @@ Nothing -> throwIO ex followredir _ ex = throwIO ex + noverification = maybe noop unableIncremental iv + {- Download a perhaps large file using conduit, with auto-resume - of incomplete downloads. - @@ -456,8 +463,8 @@ - thrown for reasons other than http status codes will still be thrown - as usual.) -} -downloadConduit :: MeterUpdate -> Request -> FilePath -> UrlOptions -> IO () -downloadConduit meterupdate req file uo = +downloadConduit :: MeterUpdate -> Maybe IncrementalVerifier -> Request -> FilePath -> UrlOptions -> IO () +downloadConduit meterupdate iv req file uo = catchMaybeIO (getFileSize (toRawFilePath file)) >>= \case Just sz | sz > 0 -> resumedownload sz _ -> join $ runResourceT $ do @@ -504,7 +511,9 @@ store zeroBytesProcessed WriteMode resp return (return ()) else if alreadydownloaded sz resp - then return (return ()) + then do + liftIO noverification + return (return ()) else do rf <- extractFromResourceT (respfailure resp) if responseStatus resp == unauthorized401 @@ -529,13 +538,13 @@ Nothing -> True store initialp mode resp = - sinkResponseFile meterupdate initialp file mode resp + sinkResponseFile meterupdate iv initialp file mode resp respfailure = B8.toString . statusMessage . responseStatus retryauthed (ba, signalsuccess) = do r <- tryNonAsync $ downloadConduit - meterupdate + meterupdate iv (applyBasicAuth' ba req) file (uo { getBasicAuth = noBasicAuth }) @@ -545,32 +554,44 @@ () <- signalsuccess False throwM e -{- Sinks a Response's body to a file. The file can either be opened in - - WriteMode or AppendMode. Updates the meter as data is received. + noverification = maybe noop unableIncremental iv + +{- Sinks a Response's body to a file. The file can either be appended to + - (AppendMode), or written from the start of the response (WriteMode). + - Updates the meter and incremental verifier as data is received, + - when not appending. - - Note that the responseStatus is not checked by this function. -} sinkResponseFile :: MonadResource m => MeterUpdate + -> Maybe IncrementalVerifier -> BytesProcessed -> FilePath -> IOMode -> Response (ConduitM () B8.ByteString m ()) -> m () -sinkResponseFile meterupdate initialp file mode resp = do +sinkResponseFile meterupdate iv initialp file mode resp = do + ui <- case (iv, mode) of + (Just iv', AppendMode) -> do + liftIO $ unableIncremental iv' + return (const noop) + (Just iv', _) -> return (updateIncremental iv') + (Nothing, _) -> return (const noop) (fr, fh) <- allocate (openBinaryFile file mode) hClose - runConduit $ responseBody resp .| go initialp fh + runConduit $ responseBody resp .| go ui initialp fh release fr where - go sofar fh = await >>= \case + go ui sofar fh = await >>= \case Nothing -> return () Just bs -> do let sofar' = addBytesProcessed sofar (B.length bs) liftIO $ do void $ meterupdate sofar' + () <- ui bs B.hPut fh bs - go sofar' fh + go ui sofar' fh {- Downloads at least the specified number of bytes from an url. -} downloadPartial :: URLString -> UrlOptions -> Int -> IO (Maybe L.ByteString) diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn --- a/doc/git-annex-copy.mdwn +++ b/doc/git-annex-copy.mdwn @@ -74,10 +74,10 @@ Use this option to copy a specified key. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to copy. + can be used to specify what to copy. * `--batch` @@ -93,10 +93,13 @@ machine-parseable, you may want to use --json in combination with --batch. +* `--batch-keys` + + This is like `--batch` but the lines read from stdin are parsed as keys. + * `-z` - Makes the `--batch` input be delimited by nulls instead of the usual - newlines. + Makes batch input be delimited by nulls instead of the usual newlines. * `--json` diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -87,10 +87,10 @@ Note that this bypasses checking the .gitattributes annex.numcopies setting and required content settings. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to drop. + can be used to specify what to drop. * `--jobs=N` `-JN` @@ -110,10 +110,17 @@ match specified matching options, or it is not an annexed file, a blank line is output in response instead. +* `--batch-keys` + + This is like `--batch` but the lines read from stdin are parsed as keys. + + Note that this bypasses checking the .gitattributes annex.numcopies + setting and required content settings. + * `-z` - Makes the `--batch` input be delimited by nulls instead of the usual - newlines. + Makes the batch input be delimited by nulls + instead of the usual newlines. * `--json` diff --git a/doc/git-annex-find.mdwn b/doc/git-annex-find.mdwn --- a/doc/git-annex-find.mdwn +++ b/doc/git-annex-find.mdwn @@ -72,6 +72,10 @@ or otherwise doesn't meet the matching options, an empty line will be output instead. +* `--batch-keys` + + This is like `--batch` but the lines read from stdin are parsed as keys. + * `-z` Makes the `--batch` input be delimited by nulls instead of the usual diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn --- a/doc/git-annex-fsck.mdwn +++ b/doc/git-annex-fsck.mdwn @@ -89,10 +89,10 @@ Use this option to fsck a specified key. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to fsck. + can be used to control what to fsck. * `--jobs=N` `-JN` diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn --- a/doc/git-annex-get.mdwn +++ b/doc/git-annex-get.mdwn @@ -56,10 +56,10 @@ parallel. (Remotes with lower costs are still preferred over higher cost remotes.) -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to get. + can be used to control what to get. * `--incomplete` @@ -114,9 +114,13 @@ machine-parseable, you may want to use --json in combination with --batch. +* `--batch-keys` + + This is like `--batch` but the lines read from stdin are parsed as keys. + * `-z` - Makes the `--batch` input be delimited by nulls instead of the usual + Makes batch input be delimited by nulls instead of the usual newlines. * `--json` diff --git a/doc/git-annex-log.mdwn b/doc/git-annex-log.mdwn --- a/doc/git-annex-log.mdwn +++ b/doc/git-annex-log.mdwn @@ -39,10 +39,10 @@ Generates output suitable for the `gource` visualization program. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to act on. + can be used to control what to act on. * `--all` `-A` diff --git a/doc/git-annex-matching-options.mdwn b/doc/git-annex-matching-options.mdwn --- a/doc/git-annex-matching-options.mdwn +++ b/doc/git-annex-matching-options.mdwn @@ -1,11 +1,12 @@ # NAME -git-annex-matching-options - specifying files to act on +git-annex-matching-options - specifying what to act on # DESCRIPTION Many git-annex commands support using these options to specify which -files they act on. +files they act on. Some of these options can also be used by commands to +specify which keys they act on. Arbitrarily complicated expressions can be built using these options. For example: @@ -58,8 +59,8 @@ * `--in=repository` - Matches only files that git-annex believes have their contents present - in a repository. Note that it does not check the repository to verify + Matches only when git-annex believes that the content is present in a + repository. Note that it does not check the repository to verify that it still has the content. The repository should be specified using the name of a configured remote, @@ -68,8 +69,8 @@ * `--in=repository@{date}` - Matches files currently in the work tree whose content was present in - the repository on the given date. + Matches only when the content was present in a repository on the given + date. The date is specified in the same syntax documented in gitrevisions(7). Note that this uses the reflog, so dates far in the @@ -81,13 +82,13 @@ * `--copies=number` - Matches only files that git-annex believes to have the specified number + Matches only when git-annex believes there are the specified number of copies, or more. Note that it does not check remotes to verify that the copies still exist. * `--copies=trustlevel:number` - Matches only files that git-annex believes have the specified number of + Matches only when git-annex believes there are the specified number of copies, on remotes with the specified trust level. For example, `--copies=trusted:2` @@ -96,14 +97,14 @@ * `--copies=groupname:number` - Matches only files that git-annex believes have the specified number of + Matches only when git-annex believes there are the specified number of copies, on remotes in the specified group. For example, `--copies=archive:2` * `--lackingcopies=number` - Matches only files that git-annex believes need the specified number or - more additional copies to be made in order to satisfy their numcopies + Matches only when git-annex beleives that the specified number or + more additional copies to be made in order to satisfy numcopies settings. * `--approxlackingcopies=number` @@ -113,23 +114,23 @@ * `--inbackend=name` - Matches only files whose content is stored using the specified key-value + Matches only when content is stored using the specified key-value backend. * `--securehash` - Matches only files whose content is hashed using a cryptographically + Matches only when content is hashed using a cryptographically secure function. * `--inallgroup=groupname` - Matches only files that git-annex believes are present in all repositories - in the specified group. + Matches only when git-annex believes content is present in + all repositories in the specified group. * `--smallerthan=size` * `--largerthan=size` - Matches only files whose content is smaller than, or larger than the + Matches only when the content is is smaller than, or larger than the specified size. The size can be specified with any commonly used units, for example, @@ -137,14 +138,14 @@ * `--metadata field=glob` - Matches only files that have a metadata field attached with a value that + Matches only when there is a metadata field attached with a value that matches the glob. The values of metadata fields are matched case insensitively. * `--metadata fieldnumber` * `--metadata field<=number` / `--metadata field>=number` - Matches only files that have a metadata field attached with a value that + Matches only when there is a metadata field attached with a value that is a number and is less than or greater than the specified number. (Note that you will need to quote the second parameter to avoid @@ -152,34 +153,34 @@ * `--want-get` - Matches files that the preferred content settings for the repository - make it want to get. Note that this will match even files that are - already present, unless limited with e.g., `--not --in .` + Matches only when the preferred content settings for the repository + make it want to get content. Note that this will match even when + the content is already present, unless limited with e.g., `--not --in .` * `--want-drop` - Matches files that the preferred content settings for the repository - make it want to drop. Note that this will match even files that have - already been dropped, unless limited with e.g., `--in .` + Matches only when the preferred content settings for the repository + make it want to drop content. Note that this will match even when + the content is not present, unless limited with e.g., `--in .` - Files that this matches will not necessarily be dropped by + Things that this matches will not necessarily be dropped by `git-annex drop --auto`. This does not check that there are enough copies to drop. Also the same content may be used by a file that is not wanted to be dropped. * `--accessedwithin=interval` - Matches files that were accessed recently, within the specified time + Matches when the content was accessed recently, within the specified time interval. The interval can be in the form "5m" or "1h" or "2d" or "1y", or a combination such as "1h5m". - So for example, `--accessedwithin=1d` matches files that have been + So for example, `--accessedwithin=1d` matches when the content was accessed within the past day. If the OS or filesystem does not support access times, this will not - match any files. + match anything. * `--unlocked` @@ -220,8 +221,8 @@ * `--not` - Inverts the next matching option. For example, to only act on - files with less than 3 copies, use `--not --copies=3` + Inverts the next matching option. For example, to match + when there are less than 3 copies, use `--not --copies=3` * `--and` diff --git a/doc/git-annex-metadata.mdwn b/doc/git-annex-metadata.mdwn --- a/doc/git-annex-metadata.mdwn +++ b/doc/git-annex-metadata.mdwn @@ -82,10 +82,10 @@ throughout the files in a directory. This option enables such recursive setting. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to act on. + can be used to control what to act on. * `--all` `-A` @@ -159,7 +159,7 @@ {"file":"foo","fields":{"author":[]}} - Note that file matching options do not affect the files that are + Note that matching options do not affect the files that are processed when in batch mode. * Also the [[git-annex-common-options]](1) can be used. diff --git a/doc/git-annex-mirror.mdwn b/doc/git-annex-mirror.mdwn --- a/doc/git-annex-mirror.mdwn +++ b/doc/git-annex-mirror.mdwn @@ -63,10 +63,10 @@ Operate on files that have recently failed to be transferred. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to mirror. + can be used to control what to mirror. * `--json` diff --git a/doc/git-annex-move.mdwn b/doc/git-annex-move.mdwn --- a/doc/git-annex-move.mdwn +++ b/doc/git-annex-move.mdwn @@ -74,10 +74,10 @@ already has content. This can be faster, but might skip moving content to the remote in some cases. -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to move. + can be used to control what to move. * `--batch` @@ -93,10 +93,13 @@ machine-parseable, you may want to use --json in combination with --batch. +* `--batch-keys` + + This is like `--batch` but the lines read from stdin are parsed as keys. + * `-z` - Makes the `--batch` input be delimited by nulls instead of the usual - newlines. + Makes batch input be delimited by nulls instead of the usual newlines. * `--json` diff --git a/doc/git-annex-whereis.mdwn b/doc/git-annex-whereis.mdwn --- a/doc/git-annex-whereis.mdwn +++ b/doc/git-annex-whereis.mdwn @@ -26,10 +26,10 @@ # OPTIONS -* file matching options +* matching options The [[git-annex-matching-options]](1) - can be used to specify files to act on. + can be used to control what to act on. * `--key=keyname` @@ -53,12 +53,16 @@ its information displayed, and repeat. Note that if the file is not an annexed file, or does not match - specified file matching options, an empty line will be + specified matching options, an empty line will be output instead. +* `--batch-keys` + + This is like `--batch` but the lines read from stdin are parsed as keys. + * `-z` - Makes the `--batch` input be delimited by nulls instead of the usual + Makes batch input be delimited by nulls instead of the usual newlines. * `--json` diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1657,6 +1657,10 @@ file any options that cause youtube-dl to download more than one file, or to store the file anywhere other than the current working directory. +* `annex.youtube-dl-command` + + Command to run for youtube-dl. Default is "youtube-dl". + * `annex.aria-torrent-options` Options to pass to aria2c when using it to download a torrent. @@ -1908,14 +1912,13 @@ Normally git-annex timestamps lines in the log files committed to the git-annex branch. Setting this environment variable to a number - will make git-annex use that rather than the current number of seconds - since the UNIX epoch. Note that decimal seconds are supported. + will make git-annex use that (or a larger number) + rather than the current number of seconds since the UNIX epoch. + Note that decimal seconds are supported. This is only provided for advanced users who either have a better way to tell which commit is current than the local clock, or who need to avoid - embedding timestamps for policy reasons. Misuse of this environment - variable can confuse git-annex's book-keeping, sometimes in ways that - `git annex fsck` is unable to repair. + embedding timestamps for policy reasons. * Some special remotes use additional environment variables for authentication etc. For example, `AWS_ACCESS_KEY_ID` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20210803 +Version: 8.20210903 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess