diff --git a/Annex/Common.hs b/Annex/Common.hs --- a/Annex/Common.hs +++ b/Annex/Common.hs @@ -2,7 +2,7 @@ import Common as X import Types as X -import Types.Key as X +import Key as X import Types.UUID as X import Annex as X (gitRepo, inRepo, fromRepo, calcRepo) import Annex.Locations as X diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -56,14 +56,16 @@ - Also closes various handles in it. -} mergeState :: AnnexState -> Annex () mergeState st = do - st' <- liftIO $ snd <$> run st closehandles + st' <- liftIO $ snd <$> run st stopCoProcesses forM_ (M.toList $ Annex.cleanup st') $ uncurry addCleanup Annex.Queue.mergeFrom st' changeState $ \s -> s { errcounter = errcounter s + errcounter st' } - where - closehandles = do - catFileStop - checkAttrStop - hashObjectStop - checkIgnoreStop + +{- Stops all long-running git query processes. -} +stopCoProcesses :: Annex () +stopCoProcesses = do + catFileStop + checkAttrStop + hashObjectStop + checkIgnoreStop diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -1,6 +1,6 @@ {- git-annex file content managing - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -80,6 +80,7 @@ import qualified Backend import qualified Database.Keys import Types.NumCopies +import Types.Key import Annex.UUID import Annex.InodeSentinal import Utility.InodeCache @@ -307,10 +308,12 @@ (ok, verification) <- action tmpfile if ok then ifM (verifyKeyContent v verification key tmpfile) - ( do - moveAnnex key tmpfile - logStatus key InfoPresent - return True + ( ifM (moveAnnex key tmpfile) + ( do + logStatus key InfoPresent + return True + , return False + ) , do warning "verification of content failed" liftIO $ nukeFile tmpfile @@ -341,7 +344,7 @@ Just size -> do size' <- liftIO $ catchDefaultIO 0 $ getFileSize f return (size' == size) - verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendName (keyBackendName k) of + verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (keyVariety k) of Nothing -> return True Just verifier -> verifier k f @@ -465,9 +468,18 @@ - key, and one of them will probably get deleted later. So, adding the - check here would only raise expectations that git-annex cannot truely - meet. + - + - May return false, when a particular variety of key is not being + - accepted into the repository. Will display a warning message in this + - case. May also throw exceptions in some cases. -} -moveAnnex :: Key -> FilePath -> Annex () -moveAnnex key src = withObjectLoc key storeobject storedirect +moveAnnex :: Key -> FilePath -> Annex Bool +moveAnnex key src = ifM (checkSecureHashes key) + ( do + withObjectLoc key storeobject storedirect + return True + , return False + ) where storeobject dest = ifM (liftIO $ doesFileExist dest) ( alreadyhave @@ -509,6 +521,16 @@ alreadyhave = liftIO $ removeFile src +checkSecureHashes :: Key -> Annex Bool +checkSecureHashes key + | cryptographicallySecure (keyVariety key) = return True + | otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) + ( do + warning $ "annex.securehashesonly blocked adding " ++ formatKeyVariety (keyVariety key) ++ " key to annex objects" + return False + , return True + ) + populatePointerFile :: Key -> FilePath -> FilePath -> Annex () populatePointerFile k obj f = go =<< liftIO (isPointerFile f) where @@ -526,9 +548,12 @@ {- Populates the annex object file by hard linking or copying a source - file to it. -} linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult -linkToAnnex key src srcic = do - dest <- calcRepo (gitAnnexLocation key) - modifyContent dest $ linkAnnex To key src srcic dest Nothing +linkToAnnex key src srcic = ifM (checkSecureHashes key) + ( do + dest <- calcRepo (gitAnnexLocation key) + modifyContent dest $ linkAnnex To key src srcic dest Nothing + , return LinkAnnexFailed + ) {- Makes a destination file be a link or copy from the annex object. -} linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -23,7 +23,7 @@ import Data.Default import Common -import Types.Key +import Key import Types.GitConfig import Types.Difference import Utility.FileSystemEncoding diff --git a/Annex/Direct.hs b/Annex/Direct.hs --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -383,8 +383,11 @@ removeDirect k f = do void $ removeAssociatedFileUnchecked k f unlessM (inAnnex k) $ + -- If moveAnnex rejects the content of the key, + -- treat that the same as its content having changed. ifM (goodContent k f) - ( moveAnnex k f + ( unlessM (moveAnnex k f) $ + logStatus k InfoMissing , logStatus k InfoMissing ) liftIO $ do diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -117,6 +117,7 @@ , SimpleToken "groupwanted" (call matchgroupwanted) , SimpleToken "present" (simply $ limitPresent mu) , SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir) + , SimpleToken "securehash" (simply limitSecureHash) , ValueToken "copies" (usev limitCopies) , ValueToken "lackingcopies" (usev $ limitLackingCopies False) , ValueToken "approxlackingcopies" (usev $ limitLackingCopies True) diff --git a/Annex/Hook.hs b/Annex/Hook.hs --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -4,7 +4,7 @@ - not change, otherwise removing old hooks using an old version of - the script would fail. - - - Copyright 2013-2014 Joey Hess + - Copyright 2013-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,6 +21,9 @@ preCommitHook :: Git.Hook preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") + +postReceiveHook :: Git.Hook +postReceiveHook = Git.Hook "post-receive" (mkHookScript "git annex post-receive") preCommitAnnexHook :: Git.Hook preCommitAnnexHook = Git.Hook "pre-commit-annex" "" diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -172,10 +172,13 @@ go _ _ _ = failure "failed to generate a key" golocked key mcache s = do - catchNonAsync (moveAnnex key $ contentLocation source) - (restoreFile (keyFilename source) key) - populateAssociatedFiles key source - success key mcache s + v <- tryNonAsync (moveAnnex key $ contentLocation source) + case v of + Right True -> do + populateAssociatedFiles key source + success key mcache s + Right False -> giveup "failed to add content to annex" + Left e -> restoreFile (keyFilename source) key e gounlocked key (Just cache) s = do -- Remove temp directory hard link first because @@ -352,8 +355,11 @@ {- Adds a file to the work tree for the key, and stages it in the index. - The content of the key may be provided in a temp file, which will be - - moved into place. -} -addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex () + - moved into place. + - + - When the content of the key is not accepted into the annex, returns False. + -} +addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex Bool addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect) ( do mode <- maybe @@ -363,12 +369,13 @@ stagePointerFile file mode =<< hashPointerFile key Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) case mtmp of - Just tmp -> do - moveAnnex key tmp - linkunlocked mode + Just tmp -> ifM (moveAnnex key tmp) + ( linkunlocked mode >> return True + , writepointer mode >> return False + ) Nothing -> ifM (inAnnex key) - ( linkunlocked mode - , liftIO $ writePointerFile file key mode + ( linkunlocked mode >> return True + , writepointer mode >> return True ) , do addLink file key Nothing @@ -381,7 +388,7 @@ whenM isDirect $ Annex.Queue.flush moveAnnex key tmp - Nothing -> return () + Nothing -> return True ) where linkunlocked mode = do @@ -390,3 +397,4 @@ LinkAnnexFailed -> liftIO $ writePointerFile file key mode _ -> return () + writepointer mode = liftIO $ writePointerFile file key mode diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -1,6 +1,6 @@ {- git-annex repository initialization - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -26,6 +26,7 @@ import qualified Annex.Branch import Logs.UUID import Logs.Trust.Basic +import Logs.Config import Types.TrustLevel import Annex.Version import Annex.Difference @@ -83,8 +84,9 @@ checkLockSupport checkFifoSupport checkCrippledFileSystem - unlessM isBareRepo $ + unlessM isBareRepo $ do hookWrite preCommitHook + hookWrite postReceiveHook setDifferences unlessM (isJust <$> getVersion) $ setVersion (fromMaybe defaultVersion mversion) @@ -109,11 +111,13 @@ , unlessM isBareRepo switchHEADBack ) + propigateSecureHashesOnly createInodeSentinalFile False uninitialize :: Annex () uninitialize = do hookUnWrite preCommitHook + hookUnWrite postReceiveHook removeRepoUUID removeVersion @@ -255,3 +259,12 @@ u <- getUUID trustSet u UnTrusted setConfig (annexConfig "hardlink") (Git.Config.boolConfig True) + +{- Propigate annex.securehashesonly from then global config to local + - config. This makes a clone inherit a parent's setting, but once + - a repository has a local setting, changes to the global config won't + - affect it. -} +propigateSecureHashesOnly :: Annex () +propigateSecureHashesOnly = + maybe noop (setConfig (ConfigKey "annex.securehashesonly")) + =<< getGlobalConfig "annex.securehashesonly" diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -77,6 +77,7 @@ import Data.Default import Common +import Key import Types.Key import Types.UUID import Types.GitConfig @@ -478,7 +479,7 @@ | null s = True -- it's not legal for a key to have no keyName | otherwise= Just k == fileKey (keyFile k) where - k = stubKey { keyName = s, keyBackendName = "test" } + k = stubKey { keyName = s, keyVariety = OtherKey "test" } {- A location to store a key on a special remote that uses a filesystem. - A directory hash is used, to protect against filesystems that dislike diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -24,7 +24,7 @@ import Annex.Common import Utility.FileMode -import Git.SharedRepository +import Git.ConfigTypes import qualified Annex import Config diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex ssh interface, with connection caching - - - Copyright 2012-2015 Joey Hess + - Copyright 2012-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,6 +8,7 @@ {-# LANGUAGE CPP #-} module Annex.Ssh ( + ConsumeStdin(..), sshOptions, sshCacheDir, sshReadPort, @@ -41,10 +42,15 @@ import Annex.LockPool #endif +{- Some ssh commands are fed stdin on a pipe and so should be allowed to + - consume it. But ssh commands that are not piped stdin should generally + - not be allowed to consume the process's stdin. -} +data ConsumeStdin = ConsumeStdin | NoConsumeStdin + {- Generates parameters to ssh to a given host (or user@host) on a given - port. This includes connection caching parameters, and any ssh-options. -} -sshOptions :: (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] -sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port) +sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] +sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port) where go (Nothing, params) = ret params go (Just socketfile, params) = do @@ -55,6 +61,9 @@ , map Param (remoteAnnexSshOptions gc) , opts , portParams port + , case cs of + ConsumeStdin -> [] + NoConsumeStdin -> [Param "-n"] , [Param "-T"] ] @@ -249,7 +258,8 @@ - options. (The options are separated by newlines.) - - This is a workaround for GIT_SSH not being able to contain - - additional parameters to pass to ssh. -} + - additional parameters to pass to ssh. (GIT_SSH_COMMAND can, + - but is not supported by older versions of git.) -} sshOptionsEnv :: String sshOptionsEnv = "GIT_ANNEX_SSHOPTION" diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -1,6 +1,6 @@ {- git-annex transfers - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -26,6 +26,7 @@ import Annex.Perms import Utility.Metered import Annex.LockPool +import Types.Key import Types.Remote (Verification(..)) import qualified Types.Remote as Remote import Types.Concurrency @@ -87,7 +88,7 @@ alwaysRunTransfer = runTransfer' True runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v -runTransfer' ignorelock t file shouldretry transferaction = do +runTransfer' ignorelock t file shouldretry transferaction = checkSecureHashes t $ do info <- liftIO $ startTransferInfo file (meter, tfile, metervar) <- mkProgressUpdater t info mode <- annexFileMode @@ -166,6 +167,30 @@ | otherwise = do f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) liftIO $ catchDefaultIO 0 $ getFileSize f + +{- Avoid download and upload of keys with insecure content when + - annex.securehashesonly is configured. + - + - This is not a security check. Even if this let the content be + - downloaded, the actual security checks would prevent the content from + - being added to the repository. The only reason this is done here is to + - avoid transferring content that's going to be rejected anyway. + - + - We assume that, if annex.securehashesonly is set and the local repo + - still contains content using an insecure hash, remotes will likewise + - tend to be configured to reject it, so Upload is also prevented. + -} +checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v +checkSecureHashes t a + | cryptographicallySecure variety = a + | otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) + ( do + warning $ "annex.securehashesonly blocked transfer of " ++ formatKeyVariety variety ++ " key" + return observeFailure + , a + ) + where + variety = keyVariety (transferKey t) type RetryDecider = TransferInfo -> TransferInfo -> Bool diff --git a/Annex/UpdateInstead.hs b/Annex/UpdateInstead.hs new file mode 100644 --- /dev/null +++ b/Annex/UpdateInstead.hs @@ -0,0 +1,27 @@ +{- git-annex UpdateIntead emulation + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.UpdateInstead where + +import qualified Annex +import Annex.Common +import Config +import Annex.Version +import Annex.AdjustedBranch +import Git.Branch +import Git.ConfigTypes + +{- receive.denyCurrentBranch=updateInstead does not work in direct mode + - repositories or when an adjusted branch is checked out, so must be + - emulated. -} +needUpdateInsteadEmulation :: Annex Bool +needUpdateInsteadEmulation = updateinsteadset <&&> (isDirect <||> isadjusted) + where + updateinsteadset = (== UpdateInstead) . receiveDenyCurrentBranch + <$> Annex.getGitConfig + isadjusted = versionSupportsUnlockedPointers + <&&> (maybe False (isJust . getAdjustment) <$> inRepo Git.Branch.current) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -39,6 +39,7 @@ import Assistant.Unused import Logs.Unused import Types.Transfer +import Types.Key import Annex.Path import qualified Annex #ifdef WITH_WEBAPP @@ -308,7 +309,7 @@ cleanjunk check f = case fileKey (takeFileName f) of Nothing -> cleanOld check f Just k - | "GPGHMAC" `isPrefixOf` keyBackendName k -> + | "GPGHMAC" `isPrefixOf` formatKeyVariety (keyVariety k) -> cleanOld check f | otherwise -> noop diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -115,7 +115,7 @@ | otherwise = cleanup where k = distributionKey d - fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of + fsckit f = case Backend.maybeLookupBackendVariety (Types.Key.keyVariety k) of Nothing -> return $ Just f Just b -> case Types.Backend.verifyKeyContent b of Nothing -> return $ Just f @@ -324,7 +324,7 @@ ifM (Url.downloadQuiet distributionInfoUrl infof uo <&&> Url.downloadQuiet distributionInfoSigUrl sigf uo <&&> verifyDistributionSig gpgcmd sigf) - ( readish <$> readFileStrict infof + ( parseInfoFile <$> readFileStrict infof , return Nothing ) diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -379,7 +379,7 @@ geti f = maybe "" T.unpack (f sshinput) go extraopts environ = processTranscript' - (askPass environ) "ssh" (extraopts ++ opts) + (askPass environ (proc "ssh" (extraopts ++ opts))) -- Always provide stdin, even when empty. (Just (fromMaybe "" input)) @@ -746,7 +746,9 @@ probeuuid sshdata = do r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata) getUncachedUUID . either (const r) fst <$> - Remote.Helper.Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] [] + Remote.Helper.Ssh.onRemote NoConsumeStdin r + (Git.Config.fromPipe r, return (Left $ error "configlist failed")) + "configlist" [] [] verifysshworks sshdata = inRepo $ Git.Command.runBool [ Param "send-pack" , Param (fromJust $ sshRepoUrl sshdata) diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -1,6 +1,6 @@ {- git-annex key/value backends - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,14 +11,15 @@ genKey, getBackend, chooseBackend, - lookupBackendName, - maybeLookupBackendName, + lookupBackendVariety, + maybeLookupBackendVariety, isStableKey, ) where import Annex.Common import qualified Annex import Annex.CheckAttr +import Types.Key import Types.KeySource import qualified Types.Backend as B @@ -42,14 +43,15 @@ f <- Annex.getState Annex.forcebackend case f of Just name | not (null name) -> - return [lookupBackendName name] + return [lookupname name] _ -> do l' <- gen . annexBackends <$> Annex.getGitConfig Annex.changeState $ \s -> s { Annex.backends = l' } return l' where gen [] = list - gen l = map lookupBackendName l + gen ns = map lookupname ns + lookupname = lookupBackendVariety . parseKeyVariety {- Generates a key for a file, trying each backend in turn until one - accepts it. -} @@ -73,33 +75,33 @@ | otherwise = c getBackend :: FilePath -> Key -> Annex (Maybe Backend) -getBackend file k = let bname = keyBackendName k in - case maybeLookupBackendName bname of - Just backend -> return $ Just backend - Nothing -> do - warning $ "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")" - return Nothing +getBackend file k = case maybeLookupBackendVariety (keyVariety k) of + Just backend -> return $ Just backend + Nothing -> do + warning $ "skipping " ++ file ++ " (unknown backend " ++ formatKeyVariety (keyVariety k) ++ ")" + return Nothing {- Looks up the backend that should be used for a file. - That can be configured on a per-file basis in the gitattributes file. -} chooseBackend :: FilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go where - go Nothing = maybeLookupBackendName <$> checkAttr "annex.backend" f + go Nothing = maybeLookupBackendVariety . parseKeyVariety + <$> checkAttr "annex.backend" f go (Just _) = Just . Prelude.head <$> orderedList -{- Looks up a backend by name. May fail if unknown. -} -lookupBackendName :: String -> Backend -lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s +{- Looks up a backend by variety. May fail if unsupported or disabled. -} +lookupBackendVariety :: KeyVariety -> Backend +lookupBackendVariety v = fromMaybe unknown $ maybeLookupBackendVariety v where - unknown = error $ "unknown backend " ++ s + unknown = error $ "unknown backend " ++ formatKeyVariety v -maybeLookupBackendName :: String -> Maybe Backend -maybeLookupBackendName s = M.lookup s nameMap +maybeLookupBackendVariety :: KeyVariety -> Maybe Backend +maybeLookupBackendVariety v = M.lookup v varietyMap -nameMap :: M.Map String Backend -nameMap = M.fromList $ zip (map B.name list) list +varietyMap :: M.Map KeyVariety Backend +varietyMap = M.fromList $ zip (map B.backendVariety list) list isStableKey :: Key -> Bool isStableKey k = maybe False (`B.isStableKey` k) - (maybeLookupBackendName (keyBackendName k)) + (maybeLookupBackendVariety (keyVariety k)) diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -1,12 +1,10 @@ {- git-annex hashing backends - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Backend.Hash ( backends, testKeyBackend, @@ -14,6 +12,7 @@ import Annex.Common import qualified Annex +import Types.Key import Types.Backend import Types.KeySource import Utility.Hash @@ -29,17 +28,14 @@ | SHA2Hash HashSize | SHA3Hash HashSize | SkeinHash HashSize -type HashSize = Int {- Order is slightly significant; want SHA256 first, and more general - sizes earlier. -} hashes :: [Hash] hashes = concat - [ map SHA2Hash [256, 512, 224, 384] -#ifdef WITH_CRYPTONITE - , map SHA3Hash [256, 512, 224, 384] -#endif - , map SkeinHash [256, 512] + [ map (SHA2Hash . HashSize) [256, 512, 224, 384] + , map (SHA3Hash . HashSize) [256, 512, 224, 384] + , map (SkeinHash . HashSize) [256, 512] , [SHA1Hash] , [MD5Hash] ] @@ -50,7 +46,7 @@ genBackend :: Hash -> Backend genBackend hash = Backend - { name = hashName hash + { backendVariety = hashKeyVariety hash (HasExt False) , getKey = keyValue hash , verifyKeyContent = Just $ checkKeyChecksum hash , canUpgradeKey = Just needsUpgrade @@ -60,19 +56,16 @@ genBackendE :: Hash -> Backend genBackendE hash = (genBackend hash) - { name = hashNameE hash + { backendVariety = hashKeyVariety hash (HasExt True) , getKey = keyValueE hash } -hashName :: Hash -> String -hashName MD5Hash = "MD5" -hashName SHA1Hash = "SHA1" -hashName (SHA2Hash size) = "SHA" ++ show size -hashName (SHA3Hash size) = "SHA3_" ++ show size -hashName (SkeinHash size) = "SKEIN" ++ show size - -hashNameE :: Hash -> String -hashNameE hash = hashName hash ++ "E" +hashKeyVariety :: Hash -> HasExt -> KeyVariety +hashKeyVariety MD5Hash = MD5Key +hashKeyVariety SHA1Hash = SHA1Key +hashKeyVariety (SHA2Hash size) = SHA2Key size +hashKeyVariety (SHA3Hash size) = SHA3Key size +hashKeyVariety (SkeinHash size) = SKEINKey size {- A key is a hash of its contents. -} keyValue :: Hash -> KeySource -> Annex (Maybe Key) @@ -82,7 +75,7 @@ s <- hashFile hash file filesize return $ Just $ stubKey { keyName = s - , keyBackendName = hashName hash + , keyVariety = hashKeyVariety hash (HasExt False) , keySize = Just filesize } @@ -92,7 +85,7 @@ where addE k = return $ Just $ k { keyName = keyName k ++ selectExtension (keyFilename source) - , keyBackendName = hashNameE hash + , keyVariety = hashKeyVariety hash (HasExt True) } selectExtension :: FilePath -> String @@ -149,24 +142,29 @@ trivialMigrate :: Key -> Backend -> AssociatedFile -> Maybe Key trivialMigrate oldkey newbackend afile {- Fast migration from hashE to hash backend. -} - | keyBackendName oldkey == name newbackend ++ "E" = Just $ oldkey + | migratable && hasExt newvariety = Just $ oldkey { keyName = keyHash oldkey - , keyBackendName = name newbackend + , keyVariety = newvariety } {- Fast migration from hash to hashE backend. -} - | keyBackendName oldkey ++"E" == name newbackend = case afile of + | migratable && hasExt oldvariety = case afile of Nothing -> Nothing Just file -> Just $ oldkey { keyName = keyHash oldkey ++ selectExtension file - , keyBackendName = name newbackend + , keyVariety = newvariety } | otherwise = Nothing + where + migratable = oldvariety /= newvariety + && sameExceptExt oldvariety newvariety + oldvariety = keyVariety oldkey + newvariety = backendVariety newbackend hashFile :: Hash -> FilePath -> Integer -> Annex String hashFile hash file filesize = go hash where go MD5Hash = use md5Hasher - go SHA1Hash = usehasher 1 + go SHA1Hash = usehasher (HashSize 1) go (SHA2Hash hashsize) = usehasher hashsize go (SHA3Hash hashsize) = use (sha3Hasher hashsize) go (SkeinHash hashsize) = use (skeinHasher hashsize) @@ -176,10 +174,10 @@ -- Force full evaluation so file is read and closed. return (length h `seq` h) - usehasher hashsize = case shaHasher hashsize filesize of + usehasher hashsize@(HashSize sz) = case shaHasher hashsize filesize of Left sha -> use sha Right (external, internal) -> do - v <- liftIO $ externalSHA external hashsize file + v <- liftIO $ externalSHA external sz file case v of Right r -> return r Left e -> do @@ -189,7 +187,7 @@ use internal shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) (String, L.ByteString -> String) -shaHasher hashsize filesize +shaHasher (HashSize hashsize) filesize | hashsize == 1 = use SysConfig.sha1 sha1 | hashsize == 256 = use SysConfig.sha256 sha2_256 | hashsize == 224 = use SysConfig.sha224 sha2_224 @@ -209,17 +207,15 @@ usehasher hasher = show . hasher sha3Hasher :: HashSize -> (L.ByteString -> String) -sha3Hasher hashsize -#ifdef WITH_CRYPTONITE +sha3Hasher (HashSize hashsize) | hashsize == 256 = show . sha3_256 | hashsize == 224 = show . sha3_224 | hashsize == 384 = show . sha3_384 | hashsize == 512 = show . sha3_512 -#endif | otherwise = error $ "unsupported SHA3 size " ++ show hashsize skeinHasher :: HashSize -> (L.ByteString -> String) -skeinHasher hashsize +skeinHasher (HashSize hashsize) | hashsize == 256 = show . skein256 | hashsize == 512 = show . skein512 | otherwise = error $ "unsupported SKEIN size " ++ show hashsize @@ -236,7 +232,7 @@ -} testKeyBackend :: Backend testKeyBackend = - let b = genBackendE (SHA2Hash 256) + let b = genBackendE (SHA2Hash (HashSize 256)) in b { getKey = (fmap addE) <$$> getKey b } where addE k = k { keyName = keyName k ++ longext } diff --git a/Backend/URL.hs b/Backend/URL.hs --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -11,6 +11,7 @@ ) where import Annex.Common +import Types.Key import Types.Backend import Backend.Utilities @@ -19,7 +20,7 @@ backend :: Backend backend = Backend - { name = "URL" + { backendVariety = URLKey , getKey = const $ return Nothing , verifyKeyContent = Nothing , canUpgradeKey = Nothing @@ -33,6 +34,6 @@ fromUrl :: String -> Maybe Integer -> Key fromUrl url size = stubKey { keyName = genKeyName url - , keyBackendName = "URL" + , keyVariety = URLKey , keySize = size } diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -8,6 +8,7 @@ module Backend.WORM (backends) where import Annex.Common +import Types.Key import Types.Backend import Types.KeySource import Backend.Utilities @@ -18,7 +19,7 @@ backend :: Backend backend = Backend - { name = "WORM" + { backendVariety = WORMKey , getKey = keyValue , verifyKeyContent = Nothing , canUpgradeKey = Nothing @@ -37,7 +38,7 @@ relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) return $ Just $ stubKey { keyName = genKeyName relf - , keyBackendName = name backend + , keyVariety = WORMKey , keySize = Just sz , keyMtime = Just $ modificationTime stat } diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -34,7 +34,7 @@ , TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null" , TestCase "curl" $ testCmd "curl" "curl --version >/dev/null" , TestCase "wget" $ testCmd "wget" "wget --version >/dev/null" - , TestCase "wget supports -q --show-progress" checkWgetQuietProgress + , TestCase "wget unclutter options" checkWgetUnclutter , TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" , TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null" @@ -105,8 +105,8 @@ error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)" return $ Config "gitversion" $ StringConfig $ show v -checkWgetQuietProgress :: Test -checkWgetQuietProgress = Config "wgetquietprogress" . BoolConfig +checkWgetUnclutter :: Test +checkWgetUnclutter = Config "wgetunclutter" . BoolConfig . maybe False (>= normalize "1.16") <$> getWgetVersion diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs --- a/Build/DistributionUpdate.hs +++ b/Build/DistributionUpdate.hs @@ -119,13 +119,14 @@ Just k -> whenM (inAnnex k) $ do liftIO $ putStrLn f let infofile = f ++ ".info" - liftIO $ writeFile infofile $ show $ GitAnnexDistribution + let d = GitAnnexDistribution { distributionUrl = mkUrl f , distributionKey = k , distributionVersion = bv , distributionReleasedate = now , distributionUrgentUpgrade = Nothing } + liftIO $ writeFile infofile $ formatInfoFile d void $ inRepo $ runBool [Param "add", File infofile] signFile infofile signFile f diff --git a/Build/EvilLinker.hs b/Build/EvilLinker.hs --- a/Build/EvilLinker.hs +++ b/Build/EvilLinker.hs @@ -127,7 +127,7 @@ putStrLn $ unwords [c, show ps] systemenviron <- getEnvironment let environ' = fromMaybe [] environ ++ systemenviron - out@(_, ok) <- processTranscript' (\p -> p { Utility.Process.env = Just environ' }) c ps Nothing + out@(_, ok) <- processTranscript' ((proc c ps) { Utility.Process.env = Just environ' }) Nothing putStrLn $ unwords [c, "finished", show ok] return out diff --git a/Build/OSXMkLibs.hs b/Build/OSXMkLibs.hs --- a/Build/OSXMkLibs.hs +++ b/Build/OSXMkLibs.hs @@ -13,7 +13,6 @@ import Control.Monad import Control.Monad.IfElse import Data.List -import Data.String.Utils import Control.Applicative import Prelude diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,71 @@ +git-annex (6.20170301) unstable; urgency=medium + + * No changes from 6.20170228; a new version number was needed due + to a problem with Hackage. + + -- Joey Hess Wed, 01 Mar 2017 12:06:02 -0400 + +git-annex (6.20170228) unstable; urgency=medium + + * Cryptographically secure hashes can be forced to be used in a + repository, by setting annex.securehashesonly. + This does not prevent the git repository from containing links + to insecure hashes, but it does prevent the content of such files + from being added to .git/annex/objects by any method. + * Tighten key parser to prevent SHA1 collision attacks generating + two keys that have the same SHA1. (Only done for keys that contain + a hash). This ensures that signed git commits of annexed files + will remain secure, as long as git-annex is using a secure hashing + backend. + * fsck: Warn about any files whose content is present, that don't + use secure hashes, when annex.securehashesonly is set. + * init: When annex.securehashesonly has been set with git-annex config, + copy that value to the annex.securehashesonly git config. + * Added --securehash option to match files using a secure hash function, + and corresponding securehash preferred content expression. + * sync, merge: Fail when the current branch has no commits yet, instead + of not merging in anything from remotes and appearing to succeed. + * Run ssh with -n whenever input is not being piped into it, + to avoid it consuming stdin that it shouldn't. + This fixes git-annex-checkpresentkey --batch remote, + which didn't output results for all keys passed into it. Other + git-annex commands that communicate with a remote over ssh may also + have been consuming stdin that they shouldn't have, which could have + impacted using them in eg, shell scripts. + * sync: Improve integration with receive.denyCurrentBranch=updateInstead, + displaying error messages from the remote then it fails to update + its checked out branch. + * Added post-recieve hook, which makes updateInstead work with direct + mode and adjusted branches. + * init: Set up the post-receive hook. + * sync: When syncing with a local repository located on a crippled + filesystem, run the post-receive hook there, since it wouldn't get run + otherwise. This makes pushing to repos on FAT-formatted removable + drives update them when receive.denyCurrentBranch=updateInstead. + * config group groupwanted numcopies schedule wanted required: + Avoid displaying extraneous messages about repository auto-init, + git-annex branch merging, etc, when being used to get information. + * adjust: Fix behavior when used in a repository that contains + submodules. + * Run wget with -nv instead of -q, so it will display HTTP errors. + * Run curl with -S, so HTTP errors are displayed, even when + it's otherwise silent. + * When downloading in --json or --quiet mode, use curl in preference + to wget, since curl is able to display only errors to stderr, unlike + wget. + * status: Pass --ignore-submodules=when option on to git status. + * config --set: As well as setting value in git-annex branch, + set local gitconfig. This is needed especially for + annex.securehashesonly, which is read only from local gitconfig and not + the git-annex branch. + * Removed support for building with the old cryptohash library. + Building with that library made git-annex not support SHA3; it's time + for that to always be supported in case SHA2 dominoes. + * git-annex.cabal: Make crypto-api a dependency even when built w/o + webapp and test suite. + + -- Joey Hess Tue, 28 Feb 2017 14:39:47 -0400 + git-annex (6.20170214) unstable; urgency=medium * Increase default cost for p2p remotes from 200 to 1000. diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -61,6 +61,7 @@ import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit +import qualified Command.PostReceive import qualified Command.Find import qualified Command.FindRef import qualified Command.Whereis @@ -148,6 +149,7 @@ , Command.Uninit.cmd , Command.Reinit.cmd , Command.PreCommit.cmd + , Command.PostReceive.cmd , Command.NumCopies.cmd , Command.Trust.cmd , Command.Untrust.cmd diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -15,6 +15,7 @@ import qualified Git.Config import qualified Git.Construct import Git.Types +import Types.Key import Types.TrustLevel import Types.NumCopies import Types.Messages @@ -223,6 +224,11 @@ <> hidden <> completeBackends ) + , globalFlag Limit.addSecureHash + ( long "securehash" + <> help "match files using a cryptographically secure hash" + <> hidden + ) , globalSetter Limit.addInAllGroup $ strOption ( long "inallgroup" <> metavar paramGroup <> help "match files present in all remotes in a group" @@ -346,4 +352,5 @@ completeBackends :: HasCompleter f => Mod f a -completeBackends = completeWith (map Backend.name Backend.list) +completeBackends = completeWith $ + map (formatKeyVariety . Backend.backendVariety) Backend.list diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs --- a/CmdLine/GlobalSetter.hs +++ b/CmdLine/GlobalSetter.hs @@ -20,5 +20,5 @@ globalSetter setter parser = DeferredParse . setter <$> parser combineGlobalOptions :: [GlobalOption] -> Parser GlobalSetter -combineGlobalOptions l = DeferredParse . sequence_ . map getParsed +combineGlobalOptions l = DeferredParse . mapM_ getParsed <$> many (foldl1 (<|>) l) diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -22,12 +22,14 @@ import CmdLine.GitAnnex.Options as ReExported import CmdLine.Batch as ReExported import Options.Applicative as ReExported hiding (command) +import qualified Annex import qualified Git import Annex.Init import Config import Utility.Daemon import Types.Transfer import Types.ActionItem +import Types.Messages {- Generates a normal Command -} command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command @@ -62,6 +64,16 @@ - etc. -} noMessages :: Command -> Command noMessages c = c { cmdnomessages = True } + +{- Undoes noMessages -} +allowMessages :: Annex () +allowMessages = do + curr <- Annex.getState Annex.output + case outputType curr of + QuietOutput -> Annex.setOutput NormalOutput + _ -> noop + Annex.changeState $ \s -> s + { Annex.output = (Annex.output s) { implicitMessages = True } } {- Adds a fallback action to a command, that will be run if it's used - outside a git repository. -} diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -356,10 +356,13 @@ where go = do maybeShowJSON $ JSONChunk [("key", key2file key)] - when (isJust mtmp) $ - logStatus key InfoPresent setUrlPresent u key url - addAnnexedFile file key mtmp + ifM (addAnnexedFile file key mtmp) + ( do + when (isJust mtmp) $ + logStatus key InfoPresent + , liftIO $ maybe noop nukeFile mtmp + ) nodownload :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) nodownload url urlinfo file diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -9,9 +9,11 @@ import Command import Logs.Config +import Config cmd :: Command -cmd = command "config" SectionSetup "configuration stored in git-annex branch" +cmd = noMessages $ command "config" SectionSetup + "configuration stored in git-annex branch" paramNothing (seek <$$> optParser) data Action @@ -47,14 +49,18 @@ seek :: Action -> CommandSeek seek (SetConfig name val) = commandAction $ do + allowMessages showStart name val next $ next $ do setGlobalConfig name val + setConfig (ConfigKey name) val return True seek (UnsetConfig name) = commandAction $ do + allowMessages showStart name "unset" next $ next $ do unsetGlobalConfig name + unsetConfig (ConfigKey name) return True seek (GetConfig name) = commandAction $ do mv <- getGlobalConfig name diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -13,6 +13,7 @@ import Command import Annex.Content import Limit +import Types.Key import qualified Utility.Format import Utility.DataUnits @@ -76,7 +77,7 @@ keyVars :: Key -> [(String, String)] keyVars key = [ ("key", key2file key) - , ("backend", keyBackendName key) + , ("backend", formatKeyVariety $ keyVariety key) , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) , ("keyname", keyName key) diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2016 Joey Hess + - Copyright 2010-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -35,6 +35,7 @@ import qualified Database.Keys import qualified Database.Fsck as FsckDb import Types.CleanupActions +import Types.Key import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) @@ -175,7 +176,7 @@ startKey :: Maybe Remote -> Incremental -> Key -> ActionItem -> NumCopies -> CommandStart startKey from inc key ai numcopies = - case Backend.maybeLookupBackendName (keyBackendName key) of + case Backend.maybeLookupBackendVariety (keyVariety key) of Nothing -> stop Just backend -> runFsck inc ai key $ case from of @@ -233,6 +234,14 @@ warning $ "** Unable to set correct write mode for " ++ obj ++ " ; perhaps you don't own that file" whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ freezeContentDir obj + + {- Warn when annex.securehashesonly is set and content using an + - insecure hash is present. This should only be able to happen + - if the repository already contained the content before the + - config was set. -} + when (present && not (cryptographicallySecure (keyVariety key))) $ + whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ + warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ formatKeyVariety (keyVariety key) ++ " key" {- In direct mode, modified files will show up as not present, - but that is expected and not something to do anything about. -} diff --git a/Command/Group.hs b/Command/Group.hs --- a/Command/Group.hs +++ b/Command/Group.hs @@ -15,7 +15,7 @@ import qualified Data.Set as S cmd :: Command -cmd = command "group" SectionSetup "add a repository to a group" +cmd = noMessages $ command "group" SectionSetup "add a repository to a group" (paramPair paramRemote paramDesc) (withParams seek) seek :: CmdParams -> CommandSeek @@ -23,12 +23,13 @@ start :: [String] -> CommandStart start (name:g:[]) = do + allowMessages showStart "group" name u <- Remote.nameToUUID name next $ setGroup u g start (name:[]) = do u <- Remote.nameToUUID name - showRaw . unwords . S.toList =<< lookupGroups u + liftIO . putStrLn . unwords . S.toList =<< lookupGroups u stop start _ = giveup "Specify a repository and a group." diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -12,7 +12,7 @@ import Command.Wanted (performGet, performSet) cmd :: Command -cmd = command "groupwanted" SectionSetup +cmd = noMessages $ command "groupwanted" SectionSetup "get or set groupwanted expression" (paramPair paramGroup (paramOptional paramExpression)) (withParams seek) @@ -23,6 +23,7 @@ start :: [String] -> CommandStart start (g:[]) = next $ performGet groupPreferredContentMapRaw g start (g:expr:[]) = do + allowMessages showStart "groupwanted" g next $ performSet groupPreferredContentSet expr g start _ = giveup "Specify a group." diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -112,8 +112,9 @@ getCache opttemplate = ifM (Annex.getState Annex.force) ( ret S.empty S.empty , do - showAction "checking known urls" + showStart "importfeed" "checking known urls" (is, us) <- unzip <$> (mapM knownItems =<< knownUrls) + showEndOk ret (S.fromList us) (S.fromList (concat is)) ) where @@ -138,12 +139,10 @@ Just $ ToDownload f u i $ Enclosure enclosureurl Nothing -> mkquvi f i mkquvi f i = case getItemLink i of - Just link -> do - liftIO $ print ("link", link) - ifM (quviSupported link) - ( return $ Just $ ToDownload f u i $ QuviLink link - , return Nothing - ) + Just link -> ifM (quviSupported link) + ( return $ Just $ ToDownload f u i $ QuviLink link + , return Nothing + ) Nothing -> return Nothing {- Feeds change, so a feed download cannot be resumed. -} diff --git a/Command/Indirect.hs b/Command/Indirect.hs --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -86,16 +86,16 @@ whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do v <- tryNonAsync (moveAnnex k f) case v of - Right _ -> do + Right True -> do l <- calcRepo $ gitAnnexLink f k liftIO $ createSymbolicLink l f - Left e -> catchNonAsync (restoreFile f k e) - warnlocked + Right False -> warnlocked "Failed to move file to annex" + Left e -> catchNonAsync (restoreFile f k e) $ + warnlocked . show showEndOk - warnlocked :: SomeException -> Annex () - warnlocked e = do - warning $ show e + warnlocked msg = do + warning msg warning "leaving this file as-is; correct this problem and run git annex add on it" cleanup :: CommandCleanup diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -36,6 +36,7 @@ import Utility.Percentage import Types.Transfer import Logs.Transfer +import Types.Key import Types.TrustLevel import Types.FileMatcher import qualified Limit @@ -51,7 +52,7 @@ { countKeys :: Integer , sizeKeys :: Integer , unknownSizeKeys :: Integer - , backendsKeys :: M.Map String Integer + , backendsKeys :: M.Map KeyVariety Integer } data NumCopiesStats = NumCopiesStats @@ -418,14 +419,14 @@ where desc = "transfers in progress" line uuidmap t i = unwords - [ showLcDirection (transferDirection t) ++ "ing" + [ formatDirection (transferDirection t) ++ "ing" , fromMaybe (key2file $ transferKey t) (associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ] jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $ - [ ("transfer", toJSON (showLcDirection (transferDirection t))) + [ ("transfer", toJSON (formatDirection (transferDirection t))) , ("key", toJSON (key2file (transferKey t))) , ("file", toJSON (associatedFile i)) , ("remote", toJSON (fromUUID (transferUUID t))) @@ -451,7 +452,8 @@ backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $ - ObjectMap . backendsKeys <$> cachedReferencedData + ObjectMap . (M.mapKeys formatKeyVariety) . backendsKeys + <$> cachedReferencedData where fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap @@ -598,7 +600,7 @@ {- All calculations strict to avoid thunks when repeatedly - applied to many keys. -} !count' = count + 1 - !backends' = M.insertWith (+) (keyBackendName key) 1 backends + !backends' = M.insertWith (+) (keyVariety key) 1 backends !size' = maybe size (+ size) ks !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks ks = keySize key diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -16,6 +16,7 @@ import qualified Git.Construct import qualified Remote import qualified Annex +import Annex.Ssh import Annex.UUID import Logs.UUID import Logs.Trust @@ -219,10 +220,11 @@ where p = proc pcmd $ toCommand params - configlist = Ssh.onRemote r (pipedconfig, return Nothing) "configlist" [] [] + configlist = Ssh.onRemote NoConsumeStdin r + (pipedconfig, return Nothing) "configlist" [] [] manualconfiglist = do gc <- Annex.getRemoteGitConfig r - sshparams <- Ssh.toRepo r gc [Param sshcmd] + sshparams <- Ssh.toRepo NoConsumeStdin r gc [Param sshcmd] liftIO $ pipedconfig "ssh" sshparams where sshcmd = "sh -c " ++ shellEscape diff --git a/Command/Merge.hs b/Command/Merge.hs --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -17,9 +17,9 @@ paramNothing (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = do - withNothing mergeBranch ps - withNothing mergeSynced ps +seek _ = do + commandAction mergeBranch + commandAction mergeSynced mergeBranch :: CommandStart mergeBranch = do diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -10,10 +10,9 @@ import Command import qualified Annex import Annex.NumCopies -import Types.Messages cmd :: Command -cmd = command "numcopies" SectionSetup +cmd = noMessages $ command "numcopies" SectionSetup "configure desired number of copies" paramNumber (withParams seek) @@ -35,7 +34,6 @@ startGet :: CommandStart startGet = next $ next $ do - Annex.setOutput QuietOutput v <- getGlobalNumCopies case v of Just n -> liftIO $ putStrLn $ show $ fromNumCopies n @@ -49,6 +47,7 @@ startSet :: Int -> CommandStart startSet n = do + allowMessages showStart "numcopies" (show n) next $ next $ do setGlobalNumCopies $ NumCopies n diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs new file mode 100644 --- /dev/null +++ b/Command/PostReceive.hs @@ -0,0 +1,51 @@ +{- git-annex command + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.PostReceive where + +import Command +import qualified Annex +import Git.Types +import Annex.UpdateInstead +import Command.Sync (mergeLocal, prepMerge, mergeConfig, getCurrBranch) + +-- This does not need to modify the git-annex branch to update the +-- work tree, but auto-initialization might change the git-annex branch. +-- Since it would be surprising for a post-receive hook to make such a +-- change, that's prevented by noCommit. +cmd :: Command +cmd = noCommit $ + command "post-receive" SectionPlumbing + "run by git post-receive hook" + paramNothing + (withParams seek) + +seek :: CmdParams -> CommandSeek +seek _ = whenM needUpdateInsteadEmulation $ do + fixPostReceiveHookEnv + commandAction updateInsteadEmulation + +{- When run by the post-receive hook, the cwd is the .git directory, + - and GIT_DIR=. It's not clear why git does this. + - + - Fix up from that unusual situation, so that git commands + - won't try to treat .git as the work tree. -} +fixPostReceiveHookEnv :: Annex () +fixPostReceiveHookEnv = do + g <- Annex.gitRepo + case location g of + Local { gitdir = ".", worktree = Just "." } -> + Annex.adjustGitRepo $ \g' -> pure $ g' + { location = (location g') + { worktree = Just ".." } + } + _ -> noop + +updateInsteadEmulation :: CommandStart +updateInsteadEmulation = do + prepMerge + mergeLocal mergeConfig =<< join getCurrBranch diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -74,9 +74,8 @@ , error "failed" ) where - move = checkDiskSpaceToGet key False $ do + move = checkDiskSpaceToGet key False $ moveAnnex key src - return True cleanup :: Key -> CommandCleanup cleanup key = do diff --git a/Command/Schedule.hs b/Command/Schedule.hs --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -8,16 +8,14 @@ module Command.Schedule where import Command -import qualified Annex import qualified Remote import Logs.Schedule import Types.ScheduledActivity -import Types.Messages import qualified Data.Set as S cmd :: Command -cmd = command "schedule" SectionSetup "get or set scheduled jobs" +cmd = noMessages $ command "schedule" SectionSetup "get or set scheduled jobs" (paramPair paramRemote (paramOptional paramExpression)) (withParams seek) @@ -29,6 +27,7 @@ where parse (name:[]) = go name performGet parse (name:expr:[]) = go name $ \uuid -> do + allowMessages showStart "schedule" name performSet expr uuid parse _ = giveup "Specify a repository." @@ -39,7 +38,6 @@ performGet :: UUID -> CommandPerform performGet uuid = do - Annex.setOutput QuietOutput s <- scheduleGet uuid liftIO $ putStrLn $ intercalate "; " $ map fromScheduledActivity $ S.toList s diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -84,7 +84,7 @@ -- for this file before, so that when -- git re-cleans a file its backend does -- not change. - currbackend <- maybe Nothing (maybeLookupBackendName . keyBackendName) + currbackend <- maybe Nothing (maybeLookupBackendVariety . keyVariety) <$> catKeyFile file liftIO . emitPointer =<< go diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -20,14 +20,28 @@ withGlobalOptions [jsonOption] $ command "status" SectionCommon "show the working tree status" - paramPaths (withParams seek) + paramPaths (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withWords start +data StatusOptions = StatusOptions + { statusFiles :: CmdParams + , ignoreSubmodules :: Maybe String + } + +optParser :: CmdParamsDesc -> Parser StatusOptions +optParser desc = StatusOptions + <$> cmdParams desc + <*> optional (strOption + ( long "ignore-submodules" + <> help "passed on to git status" + <> metavar "WHEN" + )) + +seek :: StatusOptions -> CommandSeek +seek o = withWords (start o) (statusFiles o) -start :: [FilePath] -> CommandStart -start locs = do - (l, cleanup) <- inRepo $ getStatus locs +start :: StatusOptions -> [FilePath] -> CommandStart +start o locs = do + (l, cleanup) <- inRepo $ getStatus ps locs getstatus <- ifM isDirect ( return statusDirect , return $ \s -> pure (Just s) @@ -35,6 +49,10 @@ forM_ l $ \s -> maybe noop displayStatus =<< getstatus s void $ liftIO cleanup stop + where + ps = case ignoreSubmodules o of + Nothing -> [] + Just s -> [Param $ "--ignore-submodules="++s] displayStatus :: Status -> Annex () -- renames not shown in this simplified status diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -1,7 +1,7 @@ {- git-annex command - - Copyright 2011 Joachim Breitner - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -40,6 +40,7 @@ import qualified Remote.Git import Config import Config.GitConfig +import Config.Files import Annex.Wanted import Annex.Content import Command.Get (getKey') @@ -51,6 +52,7 @@ import Annex.AdjustedBranch import Annex.Ssh import Annex.BloomFilter +import Annex.UpdateInstead import Utility.Bloom import Utility.OptParse @@ -272,22 +274,37 @@ return True mergeLocal :: [Git.Merge.MergeConfig] -> CurrBranch -> CommandStart -mergeLocal mergeconfig currbranch@(Just branch, madj) = go =<< needmerge +mergeLocal mergeconfig currbranch@(Just _, _) = + go =<< needMerge currbranch where - syncbranch = syncBranch branch - needmerge = ifM isBareRepo - ( return False - , ifM (inRepo $ Git.Ref.exists syncbranch) - ( inRepo $ Git.Branch.changed branch' syncbranch - , return False - ) - ) - go False = stop - go True = do + go Nothing = stop + go (Just syncbranch) = do showStart "merge" $ Git.Ref.describe syncbranch next $ next $ merge currbranch mergeconfig Git.Branch.ManualCommit syncbranch +mergeLocal _ (Nothing, madj) = do + b <- inRepo Git.Branch.currentUnsafe + ifM (isJust <$> needMerge (b, madj)) + ( do + warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it." + next $ next $ return False + , stop + ) + +-- Returns the branch that should be merged, if any. +needMerge :: CurrBranch -> Annex (Maybe Git.Branch) +needMerge (Nothing, _) = return Nothing +needMerge (Just branch, madj) = ifM (allM id checks) + ( return (Just syncbranch) + , return Nothing + ) + where + checks = + [ not <$> isBareRepo + , inRepo (Git.Ref.exists syncbranch) + , inRepo (Git.Branch.changed branch' syncbranch) + ] + syncbranch = syncBranch branch branch' = maybe branch (adjBranch . originalToAdjusted branch) madj -mergeLocal _ (Nothing, _) = stop pushLocal :: CurrBranch -> CommandStart pushLocal b = do @@ -362,30 +379,48 @@ showOutput ok <- inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $ pushBranch remote branch - unless ok $ do - warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] - showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)" - return ok + if ok + then postpushupdate + else do + warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] + showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)" + return ok where needpush | remoteAnnexReadOnly (Remote.gitconfig remote) = return False | otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name] + -- Do updateInstead emulation for remotes on eg removable drives + -- formatted FAT, where the post-update hook won't run. + postpushupdate + | maybe False annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) = + case Git.repoWorkTree (Remote.repo remote) of + Nothing -> return True + Just wt -> ifM (Remote.Git.onLocal remote needUpdateInsteadEmulation) + ( liftIO $ do + p <- readProgramFile + boolSystem' p [Param "post-receive"] + (\cp -> cp { cwd = Just wt }) + , return True + ) + | otherwise = return True {- Pushes a regular branch like master to a remote. Also pushes the git-annex - branch. - - - If the remote is a bare git repository, it's best to push the regular + - If the remote is a bare git repository, it's best to push the regular - branch directly to it, so that cloning/pulling will get it. - On the other hand, if it's not bare, pushing to the checked out branch - - will fail, and this is why we push to its syncBranch. + - will generally fail (except with receive.denyCurrentBranch=updateInstead), + - and this is why we push to its syncBranch. - - Git offers no way to tell if a remote is bare or not, so both methods - are tried. - - - The direct push is likely to spew an ugly error message, so stderr is - - elided. Since git progress display goes to stderr too, the sync push - - is done first, and actually sends the data. Then the direct push is - - tried, with stderr discarded, to update the branch ref on the remote. + - The direct push is likely to spew an ugly error message, so its stderr is + - often elided. Since git progress display goes to stderr too, the + - sync push is done first, and actually sends the data. Then the + - direct push is tried, with stderr discarded, to update the branch ref + - on the remote. - - The sync push forces the update of the remote synced/git-annex branch. - This is necessary if a transition has rewritten the git-annex branch. @@ -401,16 +436,30 @@ - set on the remote. -} pushBranch :: Remote -> Git.Branch -> Git.Repo -> IO Bool -pushBranch remote branch g = tryIO (directpush g) `after` syncpush g +pushBranch remote branch g = directpush `after` annexpush `after` syncpush where - syncpush = Git.Command.runBool $ pushparams + syncpush = flip Git.Command.runBool g $ pushparams [ Git.Branch.forcePush $ refspec Annex.Branch.name , refspec $ fromAdjustedBranch branch ] - directpush = Git.Command.runQuiet $ pushparams - [ Git.fromRef $ Git.Ref.base $ Annex.Branch.name - , Git.fromRef $ Git.Ref.base $ fromDirectBranch $ fromAdjustedBranch branch - ] + annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams + [ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ] + directpush = do + -- Git prints out an error message when this fails. + -- In the default configuration of receive.denyCurrentBranch, + -- the error message mentions that config setting + -- (and should even if it is localized), and is quite long, + -- and the user was not intending to update the checked out + -- branch, so in that case, avoid displaying the error + -- message. Do display other error messages though, + -- including the error displayed when + -- receive.denyCurrentBranch=updateInstead -- the user + -- will want to see that one. + let p = flip Git.Command.gitCreateProcess g $ pushparams + [ Git.fromRef $ Git.Ref.base $ fromDirectBranch $ fromAdjustedBranch branch ] + (transcript, ok) <- processTranscript' p Nothing + when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $ + hPutStr stderr transcript pushparams branches = [ Param "push" , Param $ Remote.name remote diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -149,7 +149,7 @@ Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" present b = check ("present " ++ show b) $ (== Right b) <$> Remote.hasKey r k - fsck = case maybeLookupBackendName (keyBackendName k) of + fsck = case maybeLookupBackendVariety (keyVariety k) of Nothing -> return True Just b -> case Backend.verifyKeyContent b of Nothing -> return True @@ -225,5 +225,5 @@ } k <- fromMaybe (error "failed to generate random key") <$> Backend.getKey Backend.Hash.testKeyBackend ks - moveAnnex k f + _ <- moveAnnex k f return k diff --git a/Command/Version.hs b/Command/Version.hs --- a/Command/Version.hs +++ b/Command/Version.hs @@ -11,6 +11,7 @@ import qualified Build.SysConfig as SysConfig import Annex.Version import BuildFlags +import Types.Key import qualified Types.Backend as B import qualified Types.Remote as R import qualified Remote @@ -62,7 +63,8 @@ showPackageVersion = do vinfo "git-annex version" SysConfig.packageversion vinfo "build flags" $ unwords buildFlags - vinfo "key/value backends" $ unwords $ map B.name Backend.list + vinfo "key/value backends" $ unwords $ + map (formatKeyVariety . B.backendVariety) Backend.list vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes showRawVersion :: IO () diff --git a/Command/Wanted.hs b/Command/Wanted.hs --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -8,10 +8,8 @@ module Command.Wanted where import Command -import qualified Annex import qualified Remote import Logs.PreferredContent -import Types.Messages import Types.StandardGroups import qualified Data.Map as M @@ -27,7 +25,8 @@ -> Annex (M.Map UUID PreferredContentExpression) -> (UUID -> PreferredContentExpression -> Annex ()) -> Command -cmd' name desc getter setter = command name SectionSetup desc pdesc (withParams seek) +cmd' name desc getter setter = noMessages $ + command name SectionSetup desc pdesc (withParams seek) where pdesc = paramPair paramRemote (paramOptional paramExpression) @@ -35,6 +34,7 @@ start (rname:[]) = go rname (performGet getter) start (rname:expr:[]) = go rname $ \uuid -> do + allowMessages showStart name rname performSet setter expr uuid start _ = giveup "Specify a repository." @@ -45,7 +45,6 @@ performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform performGet getter a = do - Annex.setOutput QuietOutput m <- getter liftIO $ putStrLn $ fromMaybe "" $ M.lookup a m next $ return True diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -42,6 +42,7 @@ import qualified Utility.Gpg as Gpg import Types.Crypto import Types.Remote +import Types.Key {- The beginning of a Cipher is used for MAC'ing; the remainder is used - as the GPG symmetric encryption passphrase when using the hybrid @@ -159,14 +160,16 @@ encryptKey :: Mac -> Cipher -> EncKey encryptKey mac c k = stubKey { keyName = macWithCipher mac c (key2file k) - , keyBackendName = encryptedBackendNamePrefix ++ showMac mac + , keyVariety = OtherKey (encryptedBackendNamePrefix ++ showMac mac) } encryptedBackendNamePrefix :: String encryptedBackendNamePrefix = "GPG" isEncKey :: Key -> Bool -isEncKey k = encryptedBackendNamePrefix `isPrefixOf` keyBackendName k +isEncKey k = case keyVariety k of + OtherKey s -> encryptedBackendNamePrefix `isPrefixOf` s + _ -> False type Feeder = Handle -> IO () type Reader m a = Handle -> m a diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -14,7 +14,7 @@ import Data.Char import Utility.PartialPrelude -import Types.Key +import Key import Utility.InodeCache -- A serialized Key diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs new file mode 100644 --- /dev/null +++ b/Git/ConfigTypes.hs @@ -0,0 +1,40 @@ +{- git config types + - + - Copyright 2012, 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.ConfigTypes where + +import Data.Char + +import Common +import Git +import qualified Git.Config + +data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int + deriving (Eq) + +getSharedRepository :: Repo -> SharedRepository +getSharedRepository r = + case map toLower $ Git.Config.get "core.sharedrepository" "" r of + "1" -> GroupShared + "2" -> AllShared + "group" -> GroupShared + "true" -> GroupShared + "all" -> AllShared + "world" -> AllShared + "everybody" -> AllShared + v -> maybe UnShared UmaskShared (readish v) + +data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush + deriving (Eq) + +getDenyCurrentBranch :: Repo -> DenyCurrentBranch +getDenyCurrentBranch r = + case map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of + "updateinstead" -> UpdateInstead + "warn" -> WarnPush + "ignore" -> IgnorePush + _ -> RefusePush diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -24,6 +24,7 @@ import qualified Git.Filename import Numeric +import Data.Char import System.Posix.Types data TreeItem = TreeItem @@ -66,7 +67,9 @@ , File $ fromRef t ] ++ map File fs -{- Parses a line of ls-tree output. +{- Parses a line of ls-tree output, in format: + - mode SP type SP sha TAB file + - - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem @@ -76,12 +79,9 @@ , file = sfile } where - -- l = SP SP TAB - -- All fields are fixed, so we can pull them out of - -- specific positions in the line. - (m, past_m) = splitAt 7 l - (!t, past_t) = splitAt 4 past_m - (!s, past_s) = splitAt shaSize $ Prelude.tail past_t - !f = Prelude.tail past_s + (m, past_m) = splitAt 7 l -- mode is 6 bytes + (!t, past_t) = separate isSpace past_m + (!s, past_s) = splitAt shaSize past_t + !f = drop 1 past_s !smode = fst $ Prelude.head $ readOct m !sfile = asTopFilePath $ Git.Filename.decode f diff --git a/Git/SharedRepository.hs b/Git/SharedRepository.hs deleted file mode 100644 --- a/Git/SharedRepository.hs +++ /dev/null @@ -1,28 +0,0 @@ -{- git core.sharedRepository handling - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Git.SharedRepository where - -import Data.Char - -import Common -import Git -import qualified Git.Config - -data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int - -getSharedRepository :: Repo -> SharedRepository -getSharedRepository r = - case map toLower $ Git.Config.get "core.sharedrepository" "" r of - "1" -> GroupShared - "2" -> AllShared - "group" -> GroupShared - "true" -> GroupShared - "all" -> AllShared - "world" -> AllShared - "everybody" -> AllShared - v -> maybe UnShared UmaskShared (readish v) diff --git a/Git/Status.hs b/Git/Status.hs --- a/Git/Status.hs +++ b/Git/Status.hs @@ -64,13 +64,14 @@ cparse '?' = Just Untracked cparse _ = Nothing -getStatus :: [FilePath] -> Repo -> IO ([Status], IO Bool) -getStatus l r = do - (ls, cleanup) <- pipeNullSplit params r +getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([Status], IO Bool) +getStatus ps fs r = do + (ls, cleanup) <- pipeNullSplit ps' r return (parseStatusZ ls, cleanup) where - params = - [ Param "status" - , Param "-uall" - , Param "-z" - ] ++ map File l + ps' = concat + [ [Param "status"] + , ps + , [ Param "-uall" , Param "-z"] + , map File fs + ] diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -35,11 +35,14 @@ deriving (Show) data TreeContent + -- A blob object in the tree. = TreeBlob TopFilePath FileMode Sha -- A subtree that is already recorded in git, with a known sha. | RecordedSubTree TopFilePath Sha [TreeContent] -- A subtree that has not yet been recorded in git. | NewSubTree TopFilePath [TreeContent] + -- A commit object that is part of a tree (used for submodules) + | TreeCommit TopFilePath FileMode Sha deriving (Show, Eq, Ord) {- Gets the Tree for a Ref. -} @@ -93,6 +96,7 @@ TreeBlob f fm s -> mkTreeOutput fm BlobObject s f RecordedSubTree f s _ -> mkTreeOutput 0o040000 TreeObject s f NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree" + TreeCommit f fm s -> mkTreeOutput fm CommitObject s f hPutStr h "\NUL" -- signal end of tree to --batch receive h = getSha "mktree" (hGetLine h) @@ -152,6 +156,7 @@ go _ b@(TreeBlob _ _ _) = [b] go n' (RecordedSubTree _ _ l') = concatMap (go (n'-1)) l' go n' (NewSubTree _ l') = concatMap (go (n'-1)) l' + go _ c@(TreeCommit _ _ _) = [c] {- Applies an adjustment to items in a tree. - @@ -200,6 +205,9 @@ else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) [] let !modified' = modified || slmodified || wasmodified go h modified' (subtree : c) depth intree is' + Just CommitObject -> do + let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) + go h wasmodified (ti:c) depth intree is _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") | otherwise = return (c, wasmodified, i:is) @@ -236,6 +244,9 @@ let st = RecordedSubTree (LsTree.file i) (LsTree.sha i) subtree in go (st:t) intree is' Left e -> Left e + Just CommitObject -> + let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) + in go (c:t) intree is _ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") | otherwise = Right (t, i:is) parseerr = Left @@ -259,6 +270,7 @@ gitPath (TreeBlob f _ _) = gitPath f gitPath (RecordedSubTree f _ _) = gitPath f gitPath (NewSubTree f _) = gitPath f + gitPath (TreeCommit f _ _) = gitPath f inTopTree :: GitPath t => t -> Bool inTopTree = inTree "." diff --git a/Key.hs b/Key.hs new file mode 100644 --- /dev/null +++ b/Key.hs @@ -0,0 +1,181 @@ +{- git-annex Keys + - + - Copyright 2011-2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Key ( + Key(..), + AssociatedFile, + stubKey, + key2file, + file2key, + nonChunkKey, + chunkKeyOffset, + isChunkKey, + isKeyPrefix, + + prop_isomorphic_key_encode, + prop_isomorphic_key_decode +) where + +import Data.Aeson +import Data.Char +import qualified Data.Text as T + +import Common +import Types.Key +import Utility.QuickCheck +import Utility.Bloom +import qualified Utility.SimpleProtocol as Proto + +stubKey :: Key +stubKey = Key + { keyName = "" + , keyVariety = OtherKey "" + , keySize = Nothing + , keyMtime = Nothing + , keyChunkSize = Nothing + , keyChunkNum = Nothing + } + +-- Gets the parent of a chunk key. +nonChunkKey :: Key -> Key +nonChunkKey k = k + { keyChunkSize = Nothing + , keyChunkNum = Nothing + } + +-- Where a chunk key is offset within its parent. +chunkKeyOffset :: Key -> Maybe Integer +chunkKeyOffset k = (*) + <$> keyChunkSize k + <*> (pred <$> keyChunkNum k) + +isChunkKey :: Key -> Bool +isChunkKey k = isJust (keyChunkSize k) && isJust (keyChunkNum k) + +-- Checks if a string looks like at least the start of a key. +isKeyPrefix :: String -> Bool +isKeyPrefix s = [fieldSep, fieldSep] `isInfixOf` s + +fieldSep :: Char +fieldSep = '-' + +{- Converts a key to a string that is suitable for use as a filename. + - The name field is always shown last, separated by doubled fieldSeps, + - and is the only field allowed to contain the fieldSep. -} +key2file :: Key -> FilePath +key2file Key { keyVariety = kv, keySize = s, keyMtime = m, keyChunkSize = cs, keyChunkNum = cn, keyName = n } = + formatKeyVariety kv +++ ('s' ?: s) +++ ('m' ?: m) +++ ('S' ?: cs) +++ ('C' ?: cn) +++ (fieldSep : n) + where + "" +++ y = y + x +++ "" = x + x +++ y = x ++ fieldSep:y + f ?: (Just v) = f : show v + _ ?: _ = "" + +file2key :: FilePath -> Maybe Key +file2key s + | key == Just stubKey || (keyName <$> key) == Just "" || (keyVariety <$> key) == Just (OtherKey "") = Nothing + | otherwise = key + where + key = startbackend stubKey s + + startbackend k v = sepfield k v addvariety + + sepfield k v a = case span (/= fieldSep) v of + (v', _:r) -> findfields r $ a k v' + _ -> Nothing + + findfields (c:v) (Just k) + | c == fieldSep = addkeyname k v + | otherwise = sepfield k v $ addfield c + findfields _ v = v + + addvariety k v = Just k { keyVariety = parseKeyVariety v } + + -- This is a strict parser for security reasons; a key + -- can contain only 4 fields, which all consist only of numbers. + -- Any key containing other fields, or non-numeric data is + -- rejected with Nothing. + -- + -- If a key contained non-numeric fields, they could be used to + -- embed data used in a SHA1 collision attack, which would be a + -- problem since the keys are committed to git. + addfield _ _ v | not (all isDigit v) = Nothing + addfield 's' k v = do + sz <- readish v + return $ k { keySize = Just sz } + addfield 'm' k v = do + mtime <- readish v + return $ k { keyMtime = Just mtime } + addfield 'S' k v = do + chunksize <- readish v + return $ k { keyChunkSize = Just chunksize } + addfield 'C' k v = case readish v of + Just chunknum | chunknum > 0 -> + return $ k { keyChunkNum = Just chunknum } + _ -> Nothing + addfield _ _ _ = Nothing + + addkeyname k v + | validKeyName k v = Just $ k { keyName = v } + | otherwise = Nothing + +{- When a key HasExt, the length of the extension is limited in order to + - mitigate against SHA1 collision attacks. + - + - In such an attack, the extension of the key could be made to contain + - the collision generation data, with the result that a signed git commit + - including such keys would not be secure. + - + - The maximum extension length ever generated for such a key was 8 + - characters; 20 is used here to give a little future wiggle-room. + - The SHA1 common-prefix attack needs 128 bytes of data. + -} +validKeyName :: Key -> String -> Bool +validKeyName k name + | hasExt (keyVariety k) = length (takeExtensions name) <= 20 + | otherwise = True + +instance Arbitrary Key where + arbitrary = Key + <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t") + <*> (parseKeyVariety <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND + <*> ((abs <$>) <$> arbitrary) -- size cannot be negative + <*> arbitrary + <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative + <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative + +instance Hashable Key where + hashIO32 = hashIO32 . key2file + hashIO64 = hashIO64 . key2file + +instance ToJSON Key where + toJSON = toJSON . key2file + +instance FromJSON Key where + parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t + parseJSON _ = mempty + +instance Proto.Serializable Key where + serialize = key2file + deserialize = file2key + +prop_isomorphic_key_encode :: Key -> Bool +prop_isomorphic_key_encode k = Just k == (file2key . key2file) k + +prop_isomorphic_key_decode :: FilePath -> Bool +prop_isomorphic_key_decode f + | normalfieldorder = maybe True (\k -> key2file k == f) (file2key f) + | otherwise = True + where + -- file2key will accept the fields in any order, so don't + -- try the test unless the fields are in the normal order + normalfieldorder = fields `isPrefixOf` "smSC" + fields = map (f !!) $ filter (< length f) $ map succ $ + elemIndices fieldSep f diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,6 +19,7 @@ import Annex.UUID import Logs.Trust import Annex.NumCopies +import Types.Key import Types.TrustLevel import Types.Group import Types.FileMatcher @@ -251,7 +252,15 @@ limitInBackend :: MkLimit Annex limitInBackend name = Right $ const $ checkKey check where - check key = pure $ keyBackendName key == name + check key = pure $ keyVariety key == variety + variety = parseKeyVariety name + +{- Adds a limit to skip files not using a secure hash. -} +addSecureHash :: Annex () +addSecureHash = addLimit $ Right limitSecureHash + +limitSecureHash :: MatchFiles Annex +limitSecureHash _ = checkKey $ pure . cryptographicallySecure . keyVariety {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex () diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -23,15 +23,6 @@ import Data.Time.Clock.POSIX import Control.Concurrent -showLcDirection :: Direction -> String -showLcDirection Upload = "upload" -showLcDirection Download = "download" - -readLcDirection :: String -> Maybe Direction -readLcDirection "upload" = Just Upload -readLcDirection "download" = Just Download -readLcDirection _ = Nothing - describeTransfer :: Transfer -> TransferInfo -> String describeTransfer t info = unwords [ show $ transferDirection t @@ -212,7 +203,7 @@ | "lck." `isPrefixOf` takeFileName file = Nothing | otherwise = case drop (length bits - 3) bits of [direction, u, key] -> Transfer - <$> readLcDirection direction + <$> parseDirection direction <*> pure (toUUID u) <*> fileKey key _ -> Nothing @@ -279,14 +270,14 @@ {- The directory holding transfer information files for a given Direction. -} transferDir :: Direction -> Git.Repo -> FilePath -transferDir direction r = gitAnnexTransferDir r showLcDirection direction +transferDir direction r = gitAnnexTransferDir r formatDirection direction {- The directory holding failed transfer information files for a given - Direction and UUID -} failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath failedTransferDir u direction r = gitAnnexTransferDir r "failed" - showLcDirection direction + formatDirection direction filter (/= '/') (fromUUID u) prop_read_write_transferinfo :: TransferInfo -> Bool diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -36,7 +36,7 @@ import Data.Monoid import Prelude -import Types.Key +import Key import Utility.Metered import Utility.Percentage diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,15 @@ +git-annex (6.20170228) unstable; urgency=medium + + This version of git-annex has mitigations for SHA1 hash collision + problems. + + A new annex.securehashesonly configuration, when used in combination with + signed git commits, avoids potential hash collision problems in git-annex + repositories. For details, see this web page: + + + -- Joey Hess Tue, 28 Feb 2017 13:28:50 -0400 + git-annex (6.20170101) unstable; urgency=medium XMPP support has been removed from the assistant in this release. diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -28,6 +28,7 @@ import Utility.Hash import Utility.UserInfo import Annex.UUID +import Annex.Ssh import Utility.Metered type BupRepo = String @@ -213,7 +214,7 @@ onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a onBupRemote r a command params = do c <- Annex.getRemoteGitConfig r - sshparams <- Ssh.toRepo r c [Param $ + sshparams <- Ssh.toRepo NoConsumeStdin r c [Param $ "cd " ++ dir ++ " && " ++ unwords (command : toCommand params)] liftIO $ a "ssh" sshparams where diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -118,11 +118,11 @@ {- Return the command and parameters to use for a ddar call that may need to be - made on a remote repository. This will call ssh if needed. -} -ddarRemoteCall :: DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam]) -ddarRemoteCall ddarrepo cmd params +ddarRemoteCall :: ConsumeStdin -> DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam]) +ddarRemoteCall cs ddarrepo cmd params | ddarLocal ddarrepo = return ("ddar", localParams) | otherwise = do - os <- sshOptions (host, Nothing) (ddarRepoConfig ddarrepo) [] + os <- sshOptions cs (host, Nothing) (ddarRepoConfig ddarrepo) [] return ("ssh", os ++ remoteParams) where (host, ddarrepo') = splitRemoteDdarRepo ddarrepo @@ -130,13 +130,13 @@ remoteParams = Param host : Param "ddar" : Param [cmd] : Param ddarrepo' : params {- Specialized ddarRemoteCall that includes extraction command and flags -} -ddarExtractRemoteCall :: DdarRepo -> Key -> Annex (String, [CommandParam]) -ddarExtractRemoteCall ddarrepo k = - ddarRemoteCall ddarrepo 'x' [Param "--force-stdout", Param $ key2file k] +ddarExtractRemoteCall :: ConsumeStdin -> DdarRepo -> Key -> Annex (String, [CommandParam]) +ddarExtractRemoteCall cs ddarrepo k = + ddarRemoteCall cs ddarrepo 'x' [Param "--force-stdout", Param $ key2file k] retrieve :: DdarRepo -> Retriever retrieve ddarrepo = byteRetriever $ \k sink -> do - (cmd, params) <- ddarExtractRemoteCall ddarrepo k + (cmd, params) <- ddarExtractRemoteCall NoConsumeStdin ddarrepo k let p = (proc cmd $ toCommand params) { std_out = CreatePipe } (_, Just h, _, pid) <- liftIO $ createProcess p liftIO (hClose h >> forceSuccessProcess p pid) @@ -147,7 +147,8 @@ remove :: DdarRepo -> Remover remove ddarrepo key = do - (cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key] + (cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd' + [Param $ key2file key] liftIO $ boolSystem cmd params ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool) @@ -158,7 +159,8 @@ Left _ -> Right False Right status -> Right $ isDirectory status | otherwise = do - ps <- sshOptions (host, Nothing) (ddarRepoConfig ddarrepo) [] + ps <- sshOptions NoConsumeStdin (host, Nothing) + (ddarRepoConfig ddarrepo) [] exitCode <- liftIO $ safeSystem "ssh" (ps ++ params) case exitCode of ExitSuccess -> return $ Right True @@ -178,7 +180,7 @@ {- Use "ddar t" to determine if a given key is present in a ddar archive -} inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool) inDdarManifest ddarrepo k = do - (cmd, params) <- ddarRemoteCall ddarrepo 't' [] + (cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 't' [] let p = proc cmd $ toCommand params liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do contents <- hGetContents h diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -159,7 +159,7 @@ let rsyncpath = if "/~/" `isPrefixOf` path then drop 3 path else path - opts <- sshOptions (host, Nothing) gc [] + opts <- sshOptions ConsumeStdin (host, Nothing) gc [] return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ rsyncpath, AccessShell) othertransport = return ([], loc, AccessDirect) @@ -263,7 +263,8 @@ {- Ask git-annex-shell to configure the repository as a gcrypt - repository. May fail if it is too old. -} - gitannexshellsetup = Ssh.onRemote r (boolSystem, return False) + gitannexshellsetup = Ssh.onRemote NoConsumeStdin r + (boolSystem, return False) "gcryptsetup" [ Param gcryptid ] [] denyNonFastForwards = "receive.denyNonFastForwards" @@ -398,7 +399,7 @@ | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> liftIO (catchMaybeIO $ Git.Config.read r) | not fast = extract . liftM fst <$> getM (eitherToMaybe <$>) - [ Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] [] + [ Ssh.onRemote NoConsumeStdin r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] [] , getConfigViaRsync r gc ] | otherwise = return (Nothing, r) diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -1,6 +1,6 @@ {- Standard git remotes. - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,7 @@ remote, configRead, repoAvail, + onLocal, ) where import Annex.Common @@ -54,9 +55,9 @@ import P2P.Address import Annex.Path import Creds -import Annex.CatFile import Messages.Progress import Types.NumCopies +import Annex.Concurrent import Control.Concurrent import Control.Concurrent.MSampleVar @@ -210,7 +211,9 @@ tryGitConfigRead autoinit r | haveconfig r = return r -- already read | Git.repoIsSsh r = store $ do - v <- Ssh.onRemote r (pipedconfig, return (Left $ giveup "configlist failed")) "configlist" [] configlistfields + v <- Ssh.onRemote NoConsumeStdin r + (pipedconfig, return (Left $ giveup "configlist failed")) + "configlist" [] configlistfields case v of Right r' | haveconfig r' -> return r' @@ -334,7 +337,7 @@ checkremote = Ssh.inAnnex r key checklocal = guardUsable r (cantCheck r) $ maybe (cantCheck r) return - =<< onLocal rmt (Annex.Content.inAnnexSafe key) + =<< onLocalFast rmt (Annex.Content.inAnnexSafe key) keyUrls :: Remote -> Key -> [String] keyUrls r key = map tourl locs' @@ -357,7 +360,7 @@ dropKey r key | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ - commitOnCleanup r $ onLocal r $ do + commitOnCleanup r $ onLocalFast r $ do ensureInitialized whenM (Annex.Content.inAnnex key) $ do Annex.Content.lockContentForRemoval key $ \lock -> do @@ -376,7 +379,7 @@ -- Lock content from perspective of remote, -- and then run the callback in the original -- annex monad, not the remote's. - onLocal r $ + onLocalFast r $ Annex.Content.lockContentShared key $ \vc -> ifM (Annex.Content.inAnnex key) ( liftIO $ inorigrepo $ callback vc @@ -384,7 +387,8 @@ ) | Git.repoIsSsh (repo r) = do showLocking r - Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent" + Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin + (repo r) "lockcontent" [Param $ key2file key] [] (Just hin, Just hout, Nothing, p) <- liftIO $ withFile devNull WriteMode $ \nullh -> @@ -439,7 +443,7 @@ u <- getUUID hardlink <- wantHardLink -- run copy from perspective of remote - onLocal r $ do + onLocalFast r $ do ensureInitialized v <- Annex.Content.prepSendAnnex key case v of @@ -477,7 +481,8 @@ u <- getUUID let fields = (Fields.remoteUUID, fromUUID u) : maybe [] (\f -> [(Fields.associatedFile, f)]) file - Just (cmd, params) <- Ssh.git_annex_shell (repo r) "transferinfo" + Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin + (repo r) "transferinfo" [Param $ key2file key] fields v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) pidv <- liftIO $ newEmptyMVar @@ -567,7 +572,7 @@ u <- getUUID hardlink <- wantHardLink -- run copy from perspective of remote - onLocal r $ ifM (Annex.Content.inAnnex key) + onLocalFast r $ ifM (Annex.Content.inAnnex key) ( return True , do ensureInitialized @@ -583,7 +588,7 @@ fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) fsckOnRemote r params | Git.repoIsUrl r = do - s <- Ssh.git_annex_shell r "fsck" params [] + s <- Ssh.git_annex_shell NoConsumeStdin r "fsck" params [] return $ case s of Nothing -> return False Just (c, ps) -> batchCommand c ps @@ -609,34 +614,36 @@ {- Runs an action from the perspective of a local remote. - - The AnnexState is cached for speed and to avoid resource leaks. - - However, catFileStop is called to avoid git-cat-file processes hanging - - around on removable media. - - - - The repository's git-annex branch is not updated, as an optimisation. - - No caller of onLocal can query data from the branch and be ensured - - it gets a current value. Caller of onLocal can make changes to - - the branch, however. + - However, coprocesses are stopped after each call to avoid git + - processes hanging around on removable media. -} onLocal :: Remote -> Annex a -> Annex a onLocal r a = do m <- Annex.getState Annex.remoteannexstate - case M.lookup (uuid r) m of - Nothing -> do - st <- liftIO $ Annex.new (repo r) - go st $ do - Annex.BranchState.disableUpdate - a - Just st -> go st a + go =<< maybe + (liftIO $ Annex.new $ repo r) + return + (M.lookup (uuid r) m) where cache st = Annex.changeState $ \s -> s { Annex.remoteannexstate = M.insert (uuid r) st (Annex.remoteannexstate s) } - go st a' = do + go st = do curro <- Annex.getState Annex.output (ret, st') <- liftIO $ Annex.run (st { Annex.output = curro }) $ - catFileStop `after` a' + stopCoProcesses `after` a cache st' return ret +{- Faster variant of onLocal. + - + - The repository's git-annex branch is not updated, as an optimisation. + - No caller of onLocalFast can query data from the branch and be ensured + - it gets the most current value. Caller of onLocalFast can make changes + - to the branch, however. + -} +onLocalFast :: Remote -> Annex a -> Annex a +onLocalFast r a = onLocal r $ Annex.BranchState.disableUpdate >> a + {- Copys a file with rsync unless both locations are on the same - filesystem. Then cp could be faster. -} rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool @@ -660,12 +667,13 @@ where go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup cleanup - | not $ Git.repoIsUrl (repo r) = onLocal r $ + | not $ Git.repoIsUrl (repo r) = onLocalFast r $ doQuietSideAction $ Annex.Branch.commit "update" | otherwise = void $ do Just (shellcmd, shellparams) <- - Ssh.git_annex_shell (repo r) "commit" [] [] + Ssh.git_annex_shell NoConsumeStdin + (repo r) "commit" [] [] -- Throw away stderr, since the remote may not -- have a new enough git-annex shell to diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -26,17 +26,17 @@ {- Generates parameters to ssh to a repository's host and run a command. - Caller is responsible for doing any neccessary shellEscaping of the - passed command. -} -toRepo :: Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] -toRepo r gc sshcmd = do +toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] +toRepo cs r gc sshcmd = do let opts = map Param $ remoteAnnexSshOptions gc let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r - params <- sshOptions (host, Git.Url.port r) gc opts + params <- sshOptions cs (host, Git.Url.port r) gc opts return $ params ++ Param host : sshcmd {- Generates parameters to run a git-annex-shell command on a remote - repository. -} -git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam])) -git_annex_shell r command params fields +git_annex_shell :: ConsumeStdin -> Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam])) +git_annex_shell cs r command params fields | not $ Git.repoIsUrl r = do shellopts <- getshellopts return $ Just (shellcmd, shellopts ++ fieldopts) @@ -49,7 +49,7 @@ : map shellEscape (toCommand shellopts) ++ uuidcheck u ++ map shellEscape (toCommand fieldopts) - sshparams <- toRepo r gc [Param sshcmd] + sshparams <- toRepo cs r gc [Param sshcmd] return $ Just ("ssh", sshparams) | otherwise = return Nothing where @@ -76,14 +76,15 @@ - Or, if the remote does not support running remote commands, returns - a specified error value. -} onRemote - :: Git.Repo + :: ConsumeStdin + -> Git.Repo -> (FilePath -> [CommandParam] -> IO a, Annex a) -> String -> [CommandParam] -> [(Field, String)] -> Annex a -onRemote r (with, errorval) command params fields = do - s <- git_annex_shell r command params fields +onRemote cs r (with, errorval) command params fields = do + s <- git_annex_shell cs r command params fields case s of Just (c, ps) -> liftIO $ with c ps Nothing -> errorval @@ -92,7 +93,7 @@ inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex r k = do showChecking r - onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] [] + onRemote NoConsumeStdin r (check, cantCheck r) "inannex" [Param $ key2file k] [] where check c p = dispatch =<< safeSystem c p dispatch ExitSuccess = return True @@ -101,7 +102,7 @@ {- Removes a key from a remote. -} dropKey :: Git.Repo -> Key -> Annex Bool -dropKey r key = onRemote r (boolSystem, return False) "dropkey" +dropKey r key = onRemote NoConsumeStdin r (boolSystem, return False) "dropkey" [ Param "--quiet", Param "--force" , Param $ key2file key ] @@ -133,7 +134,7 @@ -- compatability. : (Fields.direct, if unlocked then "1" else "") : maybe [] (\f -> [(Fields.associatedFile, f)]) afile - Just (shellcmd, shellparams) <- git_annex_shell (repo r) + Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin (repo r) (if direction == Download then "sendkey" else "recvkey") [ Param $ key2file key ] fields diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -122,7 +122,7 @@ let (port, sshopts') = sshReadPort sshopts userhost = takeWhile (/=':') url -- Connection caching - (Param "ssh":) <$> sshOptions + (Param "ssh":) <$> sshOptions ConsumeStdin (userhost, port) gc (map Param $ loginopt ++ sshopts') "rsh":rshopts -> return $ map Param $ "rsh" : diff --git a/RemoteDaemon/Transport/GCrypt.hs b/RemoteDaemon/Transport/GCrypt.hs --- a/RemoteDaemon/Transport/GCrypt.hs +++ b/RemoteDaemon/Transport/GCrypt.hs @@ -14,12 +14,13 @@ import Git.GCrypt import Remote.Helper.Ssh import Remote.GCrypt (accessShellConfig) +import Annex.Ssh transport :: Transport transport rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) _) ichan ochan | accessShellConfig gc = do r' <- encryptedRemote g r - v <- liftAnnex h $ git_annex_shell r' "notifychanges" [] [] + v <- liftAnnex h $ git_annex_shell ConsumeStdin r' "notifychanges" [] [] case v of Nothing -> noop Just (cmd, params) -> diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs --- a/RemoteDaemon/Transport/Ssh.hs +++ b/RemoteDaemon/Transport/Ssh.hs @@ -23,7 +23,7 @@ transport :: Transport transport rr@(RemoteRepo r _) url h ichan ochan = do - v <- liftAnnex h $ git_annex_shell r "notifychanges" [] [] + v <- liftAnnex h $ git_annex_shell ConsumeStdin r "notifychanges" [] [] case v of Nothing -> noop Just (cmd, params) -> transportUsingCmd cmd params rr url h ichan ochan diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -63,6 +63,7 @@ import qualified Logs.PreferredContent import qualified Types.MetaData import qualified Remote +import qualified Key import qualified Types.Key import qualified Types.Messages import qualified Config @@ -152,8 +153,8 @@ [ testProperty "prop_isomorphic_deencode_git" Git.Filename.prop_isomorphic_deencode , testProperty "prop_isomorphic_deencode" Utility.Format.prop_isomorphic_deencode , testProperty "prop_isomorphic_fileKey" Annex.Locations.prop_isomorphic_fileKey - , testProperty "prop_isomorphic_key_encode" Types.Key.prop_isomorphic_key_encode - , testProperty "prop_isomorphic_key_decode" Types.Key.prop_isomorphic_key_decode + , testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode + , testProperty "prop_isomorphic_key_decode" Key.prop_isomorphic_key_decode , testProperty "prop_isomorphic_shellEscape" Utility.SafeCommand.prop_isomorphic_shellEscape , testProperty "prop_isomorphic_shellEscape_multiword" Utility.SafeCommand.prop_isomorphic_shellEscape_multiword , testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape @@ -390,7 +391,7 @@ git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" annexed_notpresent sha1annexedfile writeFile tmp $ content sha1annexedfile - key <- Types.Key.key2file <$> getKey backendSHA1 tmp + key <- Key.key2file <$> getKey backendSHA1 tmp git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" annexed_present sha1annexedfile -- fromkey can't be used on a crippled filesystem, since it makes a @@ -846,9 +847,9 @@ checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" -- good opportunity to test dropkey also - git_annex "dropkey" ["--force", Types.Key.key2file annexedfilekey] + git_annex "dropkey" ["--force", Key.key2file annexedfilekey] @? "dropkey failed" - checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Types.Key.key2file annexedfilekey) + checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.key2file annexedfilekey) not <$> git_annex "dropunused" ["1"] @? "dropunused failed to fail without --force" git_annex "dropunused" ["--force", "1"] @? "dropunused failed" @@ -1959,7 +1960,7 @@ case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k - assertEqual ("bad content in location log for " ++ f ++ " key " ++ Types.Key.key2file k ++ " uuid " ++ show thisuuid) + assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid) expected (thisuuid `elem` uuids) _ -> assertFailure $ f ++ " failed to look up key" @@ -2152,7 +2153,7 @@ backendWORM = backend_ "WORM" backend_ :: String -> Types.Backend -backend_ = Backend.lookupBackendName +backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety getKey :: Types.Backend -> FilePath -> IO Types.Key getKey b f = fromJust <$> annexeval go diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -9,7 +9,7 @@ module Types.ActionItem where -import Types.Key +import Key import Types.Transfer import Git.FilePath diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead - - - Copyright 2010,2012 Joey Hess + - Copyright 2010-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,7 +13,7 @@ import Types.KeySource data BackendA a = Backend - { name :: String + { backendVariety :: KeyVariety , getKey :: KeySource -> a (Maybe Key) -- Verifies the content of a key. , verifyKeyContent :: Maybe (Key -> FilePath -> a Bool) @@ -28,7 +28,7 @@ } instance Show (BackendA a) where - show backend = "Backend { name =\"" ++ name backend ++ "\" }" + show backend = "Backend { name =\"" ++ formatKeyVariety (backendVariety backend) ++ "\" }" instance Eq (BackendA a) where - a == b = name a == name b + a == b = backendVariety a == backendVariety b diff --git a/Types/Distribution.hs b/Types/Distribution.hs --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -1,16 +1,24 @@ {- Data type for a distribution of git-annex - - - Copyright 2013 Joey Hess + - Copyright 2013, 2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Types.Distribution where +import Utility.PartialPrelude import Types.Key +import Key import Data.Time.Clock import Git.Config (isTrue, boolConfig) +import Data.String.Utils +import Control.Applicative +import Prelude + +type GitAnnexVersion = String + data GitAnnexDistribution = GitAnnexDistribution { distributionUrl :: String , distributionKey :: Key @@ -20,7 +28,39 @@ } deriving (Read, Show, Eq) -type GitAnnexVersion = String +{- The first line of the info file is in the format old versions of + - git-annex expect to read a GitAnnexDistribution. + - The remainder of the file is in the new format. + - This works because old versions of git-annex used readish to parse + - the file, and that ignores the second line. + -} +formatInfoFile :: GitAnnexDistribution -> String +formatInfoFile d = replace "keyVariant = " "keyBackendName = " (show d) ++ + "\n" ++ formatGitAnnexDistribution d + +parseInfoFile :: String -> Maybe GitAnnexDistribution +parseInfoFile s = case lines s of + (_oldformat:rest) -> parseGitAnnexDistribution (unlines rest) + _ -> Nothing + +formatGitAnnexDistribution :: GitAnnexDistribution -> String +formatGitAnnexDistribution d = unlines + [ distributionUrl d + , key2file (distributionKey d) + , distributionVersion d + , show (distributionReleasedate d) + , maybe "" show (distributionUrgentUpgrade d) + ] + +parseGitAnnexDistribution :: String -> Maybe GitAnnexDistribution +parseGitAnnexDistribution s = case lines s of + (u:k:v:d:uu:_) -> GitAnnexDistribution + <$> pure u + <*> file2key k + <*> pure v + <*> readish d + <*> pure (readish uu) + _ -> Nothing data AutoUpgrade = AskUpgrade | AutoUpgrade | NoAutoUpgrade deriving (Eq) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -18,7 +18,7 @@ import qualified Git import qualified Git.Config import qualified Git.Construct -import Git.SharedRepository +import Git.ConfigTypes import Utility.DataUnits import Config.Cost import Types.UUID @@ -82,8 +82,10 @@ , annexPidLock :: Bool , annexPidLockTimeout :: Seconds , annexAddUnlocked :: Bool + , annexSecureHashesOnly :: Bool , coreSymlinks :: Bool , coreSharedRepository :: SharedRepository + , receiveDenyCurrentBranch :: DenyCurrentBranch , gcryptId :: Maybe String , gpgCmd :: GpgCmd } @@ -135,8 +137,10 @@ , annexPidLockTimeout = Seconds $ fromMaybe 300 $ getmayberead (annex "pidlocktimeout") , annexAddUnlocked = getbool (annex "addunlocked") False + , annexSecureHashesOnly = getbool (annex "securehashesonly") False , coreSymlinks = getbool "core.symlinks" True , coreSharedRepository = getSharedRepository r + , receiveDenyCurrentBranch = getDenyCurrentBranch r , gcryptId = getmaybe "core.gcrypt-id" , gpgCmd = mkGpgCmd (getmaybe "gpg.program") } diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -1,39 +1,21 @@ {- git-annex Key data type - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -module Types.Key ( - Key(..), - AssociatedFile, - stubKey, - key2file, - file2key, - nonChunkKey, - chunkKeyOffset, - isChunkKey, - isKeyPrefix, +module Types.Key where - prop_isomorphic_key_encode, - prop_isomorphic_key_decode -) where +import Utility.PartialPrelude import System.Posix.Types -import Data.Aeson -import qualified Data.Text as T -import Common -import Utility.QuickCheck -import Utility.Bloom -import qualified Utility.SimpleProtocol as Proto - {- A Key has a unique name, which is derived from a particular backend, - and may contain other optional metadata. -} data Key = Key { keyName :: String - , keyBackendName :: String + , keyVariety :: KeyVariety , keySize :: Maybe Integer , keyMtime :: Maybe EpochTime , keyChunkSize :: Maybe Integer @@ -43,120 +25,92 @@ {- A filename may be associated with a Key. -} type AssociatedFile = Maybe FilePath -stubKey :: Key -stubKey = Key - { keyName = "" - , keyBackendName = "" - , keySize = Nothing - , keyMtime = Nothing - , keyChunkSize = Nothing - , keyChunkNum = Nothing - } - --- Gets the parent of a chunk key. -nonChunkKey :: Key -> Key -nonChunkKey k = k - { keyChunkSize = Nothing - , keyChunkNum = Nothing - } +{- There are several different varieties of keys. -} +data KeyVariety + = SHA2Key HashSize HasExt + | SHA3Key HashSize HasExt + | SKEINKey HashSize HasExt + | SHA1Key HasExt + | MD5Key HasExt + | WORMKey + | URLKey + -- Some repositories may contain keys of other varieties, + -- which can still be processed to some extent. + | OtherKey String + deriving (Eq, Ord, Read, Show) --- Where a chunk key is offset within its parent. -chunkKeyOffset :: Key -> Maybe Integer -chunkKeyOffset k = (*) - <$> keyChunkSize k - <*> (pred <$> keyChunkNum k) +{- Some varieties of keys may contain an extension at the end of the + - keyName -} +newtype HasExt = HasExt Bool + deriving (Eq, Ord, Read, Show) -isChunkKey :: Key -> Bool -isChunkKey k = isJust (keyChunkSize k) && isJust (keyChunkNum k) +newtype HashSize = HashSize Int + deriving (Eq, Ord, Read, Show) --- Checks if a string looks like at least the start of a key. -isKeyPrefix :: String -> Bool -isKeyPrefix s = [fieldSep, fieldSep] `isInfixOf` s +hasExt :: KeyVariety -> Bool +hasExt (SHA2Key _ (HasExt b)) = b +hasExt (SHA3Key _ (HasExt b)) = b +hasExt (SKEINKey _ (HasExt b)) = b +hasExt (SHA1Key (HasExt b)) = b +hasExt (MD5Key (HasExt b)) = b +hasExt WORMKey = False +hasExt URLKey = False +hasExt (OtherKey s) = end s == "E" -fieldSep :: Char -fieldSep = '-' +sameExceptExt :: KeyVariety -> KeyVariety -> Bool +sameExceptExt (SHA2Key sz1 _) (SHA2Key sz2 _) = sz1 == sz2 +sameExceptExt (SHA3Key sz1 _) (SHA3Key sz2 _) = sz1 == sz2 +sameExceptExt (SKEINKey sz1 _) (SKEINKey sz2 _) = sz1 == sz2 +sameExceptExt (SHA1Key _) (SHA1Key _) = True +sameExceptExt (MD5Key _) (MD5Key _) = True +sameExceptExt _ _ = False -{- Converts a key to a string that is suitable for use as a filename. - - The name field is always shown last, separated by doubled fieldSeps, - - and is the only field allowed to contain the fieldSep. -} -key2file :: Key -> FilePath -key2file Key { keyBackendName = b, keySize = s, keyMtime = m, keyChunkSize = cs, keyChunkNum = cn, keyName = n } = - b +++ ('s' ?: s) +++ ('m' ?: m) +++ ('S' ?: cs) +++ ('C' ?: cn) +++ (fieldSep : n) - where - "" +++ y = y - x +++ "" = x - x +++ y = x ++ fieldSep:y - f ?: (Just v) = f : show v - _ ?: _ = "" +{- Is the Key variety cryptographically secure, such that no two differing + - file contents can be mapped to the same Key? -} +cryptographicallySecure :: KeyVariety -> Bool +cryptographicallySecure (SHA2Key _ _) = True +cryptographicallySecure (SHA3Key _ _) = True +cryptographicallySecure (SKEINKey _ _) = True +cryptographicallySecure _ = False -file2key :: FilePath -> Maybe Key -file2key s - | key == Just stubKey || (keyName <$> key) == Just "" || (keyBackendName <$> key) == Just "" = Nothing - | otherwise = key +formatKeyVariety :: KeyVariety -> String +formatKeyVariety v = case v of + SHA2Key sz e -> adde e (addsz sz "SHA") + SHA3Key sz e -> adde e (addsz sz "SHA3_") + SKEINKey sz e -> adde e (addsz sz "SKEIN") + SHA1Key e -> adde e "SHA1" + MD5Key e -> adde e "MD5" + WORMKey -> "WORM" + URLKey -> "URL" + OtherKey s -> s where - key = startbackend stubKey s - - startbackend k v = sepfield k v addbackend - - sepfield k v a = case span (/= fieldSep) v of - (v', _:r) -> findfields r $ a k v' - _ -> Nothing - - findfields (c:v) (Just k) - | c == fieldSep = Just $ k { keyName = v } - | otherwise = sepfield k v $ addfield c - findfields _ v = v - - addbackend k v = Just k { keyBackendName = v } - addfield 's' k v = do - sz <- readish v - return $ k { keySize = Just sz } - addfield 'm' k v = do - mtime <- readish v - return $ k { keyMtime = Just mtime } - addfield 'S' k v = do - chunksize <- readish v - return $ k { keyChunkSize = Just chunksize } - addfield 'C' k v = case readish v of - Just chunknum | chunknum > 0 -> - return $ k { keyChunkNum = Just chunknum } - _ -> return k - addfield _ _ _ = Nothing - -instance ToJSON Key where - toJSON = toJSON . key2file - -instance FromJSON Key where - parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t - parseJSON _ = mempty - -instance Proto.Serializable Key where - serialize = key2file - deserialize = file2key - -instance Arbitrary Key where - arbitrary = Key - <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t") - <*> (listOf1 $ elements ['A'..'Z']) -- BACKEND - <*> ((abs <$>) <$> arbitrary) -- size cannot be negative - <*> arbitrary - <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative - <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative - -instance Hashable Key where - hashIO32 = hashIO32 . key2file - hashIO64 = hashIO64 . key2file - -prop_isomorphic_key_encode :: Key -> Bool -prop_isomorphic_key_encode k = Just k == (file2key . key2file) k + adde (HasExt False) s = s + adde (HasExt True) s = s ++ "E" + addsz (HashSize n) s = s ++ show n -prop_isomorphic_key_decode :: FilePath -> Bool -prop_isomorphic_key_decode f - | normalfieldorder = maybe True (\k -> key2file k == f) (file2key f) - | otherwise = True - where - -- file2key will accept the fields in any order, so don't - -- try the test unless the fields are in the normal order - normalfieldorder = fields `isPrefixOf` "smSC" - fields = map (f !!) $ filter (< length f) $ map succ $ - elemIndices fieldSep f +parseKeyVariety :: String -> KeyVariety +parseKeyVariety "SHA256" = SHA2Key (HashSize 256) (HasExt False) +parseKeyVariety "SHA256E" = SHA2Key (HashSize 256) (HasExt True) +parseKeyVariety "SHA512" = SHA2Key (HashSize 512) (HasExt False) +parseKeyVariety "SHA512E" = SHA2Key (HashSize 512) (HasExt True) +parseKeyVariety "SHA224" = SHA2Key (HashSize 224) (HasExt False) +parseKeyVariety "SHA224E" = SHA2Key (HashSize 224) (HasExt True) +parseKeyVariety "SHA384" = SHA2Key (HashSize 384) (HasExt False) +parseKeyVariety "SHA384E" = SHA2Key (HashSize 384) (HasExt True) +parseKeyVariety "SHA3_512" = SHA3Key (HashSize 512) (HasExt False) +parseKeyVariety "SHA3_512E" = SHA3Key (HashSize 512) (HasExt True) +parseKeyVariety "SHA3_384" = SHA3Key (HashSize 384) (HasExt False) +parseKeyVariety "SHA3_384E" = SHA3Key (HashSize 384) (HasExt True) +parseKeyVariety "SHA3_256" = SHA3Key (HashSize 256) (HasExt False) +parseKeyVariety "SHA3_256E" = SHA3Key (HashSize 256) (HasExt True) +parseKeyVariety "SHA3_224" = SHA3Key (HashSize 224) (HasExt False) +parseKeyVariety "SHA3_224E" = SHA3Key (HashSize 224) (HasExt True) +parseKeyVariety "SKEIN512" = SKEINKey (HashSize 512) (HasExt False) +parseKeyVariety "SKEIN512E" = SKEINKey (HashSize 512) (HasExt True) +parseKeyVariety "SKEIN256" = SKEINKey (HashSize 256) (HasExt False) +parseKeyVariety "SKEIN256E" = SKEINKey (HashSize 256) (HasExt True) +parseKeyVariety "SHA1" = SHA1Key (HasExt False) +parseKeyVariety "MD5" = MD5Key (HasExt False) +parseKeyVariety "WORM" = WORMKey +parseKeyVariety "URL" = URLKey +parseKeyVariety s = OtherKey s diff --git a/Types/Transfer.hs b/Types/Transfer.hs --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -16,8 +16,7 @@ import Control.Applicative import Prelude -{- Enough information to uniquely identify a transfer, used as the filename - - of the transfer information file. -} +{- Enough information to uniquely identify a transfer. -} data Transfer = Transfer { transferDirection :: Direction , transferUUID :: UUID @@ -46,7 +45,16 @@ stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False data Direction = Upload | Download - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Show, Read) + +formatDirection :: Direction -> String +formatDirection Upload = "upload" +formatDirection Download = "download" + +parseDirection :: String -> Maybe Direction +parseDirection "upload" = Just Upload +parseDirection "download" = Just Download +parseDirection _ = Nothing instance Arbitrary TransferInfo where arbitrary = TransferInfo diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -14,6 +14,7 @@ import Annex.Common import Annex.Content import Annex.Link +import Types.Key import Logs.Presence import qualified Annex.Queue import qualified Git @@ -73,7 +74,7 @@ let d = parentDir f liftIO $ allowWrite d liftIO $ allowWrite f - moveAnnex k f + _ <- moveAnnex k f liftIO $ removeDirectory d updateSymlinks :: Annex () @@ -130,7 +131,7 @@ where len = length l - 4 k = readKey1 (take len l) - sane = (not . null $ keyName k) && (not . null $ keyBackendName k) + sane = (not . null $ keyName k) && (not . null $ formatKeyVariety $ keyVariety k) -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key" @@ -143,7 +144,7 @@ | mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits | otherwise = stubKey { keyName = n - , keyBackendName = b + , keyVariety = parseKeyVariety b , keySize = s , keyMtime = t } @@ -161,11 +162,12 @@ mixup = wormy && isUpper (Prelude.head $ bits !! 1) showKey1 :: Key -> String -showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } = +showKey1 Key { keyName = n , keyVariety = v, keySize = s, keyMtime = t } = intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n] where showifhere Nothing = "" - showifhere (Just v) = show v + showifhere (Just x) = show x + b = formatKeyVariety v keyFile1 :: Key -> FilePath keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ showKey1 key @@ -189,7 +191,7 @@ Right l -> makekey l where getsymlink = takeFileName <$> readSymbolicLink file - makekey l = case maybeLookupBackendName bname of + makekey l = case maybeLookupBackendVariety (keyVariety k) of Nothing -> do unless (null kname || null bname || not (isLinkToAnnex l)) $ @@ -198,7 +200,7 @@ Just backend -> return $ Just (k, backend) where k = fileKey1 l - bname = keyBackendName k + bname = formatKeyVariety (keyVariety k) kname = keyName k skip = "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")" diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -4,20 +4,16 @@ - because of https://github.com/vincenthz/hs-cryptohash/issues/36 -} -{-# LANGUAGE CPP #-} - module Utility.Hash ( sha1, sha2_224, sha2_256, sha2_384, sha2_512, -#ifdef WITH_CRYPTONITE sha3_224, sha3_256, sha3_384, sha3_512, -#endif skein256, skein512, md5, @@ -31,12 +27,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as S -#ifdef WITH_CRYPTONITE import "cryptonite" Crypto.MAC.HMAC import "cryptonite" Crypto.Hash -#else -import "cryptohash" Crypto.Hash -#endif sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy @@ -53,7 +45,6 @@ sha2_512 :: L.ByteString -> Digest SHA512 sha2_512 = hashlazy -#ifdef WITH_CRYPTONITE sha3_224 :: L.ByteString -> Digest SHA3_224 sha3_224 = hashlazy @@ -65,7 +56,6 @@ sha3_512 :: L.ByteString -> Digest SHA3_512 sha3_512 = hashlazy -#endif skein256 :: L.ByteString -> Digest Skein256_256 skein256 = hashlazy @@ -86,12 +76,10 @@ , (show . sha2_512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7") , (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33") , (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7") -#ifdef WITH_CRYPTONITE , (show . sha3_224, "f4f6779e153c391bbd29c95e72b0708e39d9166c7cea51d1f10ef58a") , (show . sha3_256, "76d3bc41c9f588f7fcd0d5bf4718f8f84b1c41b20882703100b9eb9413807c01") , (show . sha3_384, "665551928d13b7d84ee02734502b018d896a0fb87eed5adb4c87ba91bbd6489410e11b0fbcc06ed7d0ebad559e5d3bb5") , (show . sha3_512, "4bca2b137edc580fe50a88983ef860ebaca36c857b1f492839d6d7392452a63c82cbebc68e3b70a2a1480b4bb5d437a7cba6ecf9d89f9ff3ccd14cd6146ea7e7") -#endif , (show . md5, "acbd18db4cc2f85cedef654fccc4a4d8") ] where diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -174,22 +174,21 @@ -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript = processTranscript' id +processTranscript cmd opts = processTranscript' (proc cmd opts) -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) -processTranscript' modproc cmd opts input = do +processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) +processTranscript' cp input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} (readf, writef) <- System.Posix.IO.createPipe readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } hClose writeh get <- mkreader readh @@ -200,12 +199,11 @@ return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p) diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -246,17 +246,16 @@ (requestHeaders r) } -{- Used to download large files, such as the contents of keys. +{- Download a perhaps large file, with auto-resume of incomplete downloads. - - - Uses wget or curl program for its progress bar. (Wget has a better one, - - so is preferred.) Which program to use is determined at run time; it - - would not be appropriate to test at configure time and build support - - for only one in. + - Uses wget or curl program for its progress bar and resuming support. + - Which program to use is determined at run time depending on which is + - in path and which works best in a particular situation. -} download :: URLString -> FilePath -> UrlOptions -> IO Bool download = download' False -{- No output, even on error. -} +{- No output to stdout. -} downloadQuiet :: URLString -> FilePath -> UrlOptions -> IO Bool downloadQuiet = download' True @@ -265,6 +264,12 @@ case parseURIRelaxed url of Just u | uriScheme u == "file:" -> curl + -- curl is preferred in quiet mode, because + -- it displays http errors to stderr, while wget + -- does not display them in quiet mode + | quiet -> ifM (inPath "curl") (curl, wget) + -- wget is preferred mostly because it has a better + -- progress bar | otherwise -> ifM (inPath "wget") (wget , curl) _ -> return False where @@ -275,12 +280,13 @@ - support, or need that option. - - When the wget version is new enough, pass options for - - a less cluttered download display. + - a less cluttered download display. Using -nv rather than -q + - avoids most clutter while still displaying http errors. -} #ifndef __ANDROID__ wgetparams = concat - [ if Build.SysConfig.wgetquietprogress && not quiet - then [Param "-q", Param "--show-progress"] + [ if Build.SysConfig.wgetunclutter && not quiet + then [Param "-nv", Param "--show-progress"] else [] , [ Param "--clobber", Param "-c", Param "-O"] ] @@ -296,8 +302,13 @@ -- curl does not create destination file -- if the url happens to be empty, so pre-create. writeFile file "" - go "curl" $ headerparams ++ quietopt "-s" ++ - [Param "-f", Param "-L", Param "-C", Param "-", Param "-#", Param "-o"] + go "curl" $ headerparams ++ quietopt "-sS" ++ + [ Param "-f" + , Param "-L" + , Param "-C", Param "-" + , Param "-#" + , Param "-o" + ] {- Run wget in a temp directory because it has been buggy - and overwritten files in the current directory, even though 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 @@ -95,6 +95,11 @@ Matches only files whose content is stored using the specified key-value backend. +* `--securehash` + + Matches only files whose content is hashed using a cryptographically + secure function. + * `--inallgroup=groupname` Matches only files that git-annex believes are present in all repositories diff --git a/doc/git-annex-merge.mdwn b/doc/git-annex-merge.mdwn --- a/doc/git-annex-merge.mdwn +++ b/doc/git-annex-merge.mdwn @@ -12,10 +12,6 @@ that is done by the sync command, but without pushing or pulling any data. -One way to use this is to put `git annex merge` into a repository's -post-receive hook. Then any syncs to the repository will update its -working copy automatically. - # SEE ALSO [[git-annex]](1) diff --git a/doc/git-annex-preferred-content.mdwn b/doc/git-annex-preferred-content.mdwn --- a/doc/git-annex-preferred-content.mdwn +++ b/doc/git-annex-preferred-content.mdwn @@ -96,6 +96,11 @@ Matches only files whose content is stored using the specified key-value backend. +* `securehash` + + Matches only files whose content is hashed using a cryptographically + secure function. + * `inallgroup=groupname` Matches only files that git-annex believes are present in all repositories diff --git a/doc/git-annex-status.mdwn b/doc/git-annex-status.mdwn --- a/doc/git-annex-status.mdwn +++ b/doc/git-annex-status.mdwn @@ -23,6 +23,11 @@ Enable JSON output. This is intended to be parsed by programs that use git-annex. Each line of output is a JSON object. +* `--ignore-submodules=when` + + This option is passed on to git status, see its man page for + details. + # SEE ALSO [[git-annex]](1) diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -542,6 +542,13 @@ See [[git-annex-pre-commit]](1) for details. +* `post-receive` + + This is meant to be called from git's post-receive hook. `git annex init` + automatically creates a post-receive hook using this. + + See [[git-annex-post-receive]](1) for details. + * `lookupkey [file ...]` Looks up key used for file. @@ -816,11 +823,26 @@ * `annex.backends` - Space-separated list of names of the key-value backends to use. - The first listed is used to store new files by default. + Space-separated list of names of the key-value backends to use + when adding new files to the repository. This is overridden by annex annex.backend configuration in the .gitattributes files. + +* `annex.securehashesonly` + + Set to true to indicate that the repository should only use + cryptographically secure hashes + (SHA2, SHA3) and not insecure hashes (MD5, SHA1) for content. + + When this is set, the contents of files using cryptographically + insecure hashes will not be allowed to be added to the repository. + + Also, git-annex fsck` will complain about any files present in + the repository that use insecure hashes. + + To configure the behavior in new clones of the repository, + this can be set in [[git-annex-config]]. * `annex.diskreserve` 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: 6.20170214 +Version: 6.20170301 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -295,9 +295,6 @@ Description: Get Network.URI from the network-uri package Default: True -Flag Cryptonite - Description: Use the cryptonite library, instead of the older cryptohash - Flag Dbus Description: Enable dbus support @@ -361,7 +358,9 @@ socks, byteable, stm-chans, - securemem + securemem, + crypto-api, + cryptonite CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs Extensions: PackageImports @@ -382,12 +381,6 @@ else Build-Depends: network (< 2.6), network (>= 2.4) - if flag(Cryptonite) - Build-Depends: cryptonite - CPP-Options: -DWITH_CRYPTONITE - else - Build-Depends: cryptohash (>= 0.11.0) - if (os(windows)) Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3), setenv, process (>= 1.3.0.0) @@ -397,8 +390,7 @@ Other-Modules: Utility.Touch.Old if flag(TestSuite) - Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun, - crypto-api + Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun CPP-Options: -DWITH_TESTSUITE if flag(S3) @@ -461,7 +453,6 @@ wai, wai-extra, blaze-builder, - crypto-api, clientsession, template-haskell, shakespeare (>= 2.0.0) @@ -538,6 +529,7 @@ Annex.Ssh Annex.TaggedPush Annex.Transfer + Annex.UpdateInstead Annex.UUID Annex.Url Annex.VariantFile @@ -743,6 +735,7 @@ Command.NotifyChanges Command.NumCopies Command.P2P + Command.PostReceive Command.PreCommit Command.Proxy Command.ReKey @@ -814,6 +807,7 @@ Git.Command Git.Command.Batch Git.Config + Git.ConfigTypes Git.Construct Git.CurrentRepo Git.DiffTree @@ -839,7 +833,6 @@ Git.Remote.Remove Git.Repair Git.Sha - Git.SharedRepository Git.Status Git.Tree Git.Types @@ -847,6 +840,7 @@ Git.UpdateIndex Git.Url Git.Version + Key Limit Limit.Wanted Logs diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,6 @@ production: true assistant: true pairing: true - cryptonite: true network-uri: true s3: true testsuite: true