packages feed

git-annex 7.20190122 → 7.20190129

raw patch · 12 files changed

+170/−54 lines, 12 files

Files

Annex/FileMatcher.hs view
@@ -30,13 +30,9 @@ import Git.FilePath import Types.Remote (RemoteConfig) import Annex.CheckAttr+import Annex.Magic import Git.CheckAttr (unspecifiedAttr) -#ifdef WITH_MAGICMIME-import Magic-import Utility.Env-#endif- import Data.Either import qualified Data.Set as S @@ -139,15 +135,7 @@  mkLargeFilesParser :: Annex (String -> [ParseResult]) mkLargeFilesParser = do-#ifdef WITH_MAGICMIME-	magicmime <- liftIO $ catchMaybeIO $ do-		m <- magicOpen [MagicMimeType]-		liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case-			Nothing -> magicLoadDefault m-			Just d -> magicLoad m-				(d </> "magic" </> "magic.mgc")-		return m-#endif+	magicmime <- liftIO initMagicMimeType 	let parse = parseToken $ commonTokens #ifdef WITH_MAGICMIME 		++ [ ValueToken "mimetype" (usev $ matchMagic magicmime) ]
+ Annex/Magic.hs view
@@ -0,0 +1,45 @@+{- Interface to libmagic+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Annex.Magic (+	Magic,+	MimeType,+	initMagicMimeType,+	getMagicMimeType,+) where++#ifdef WITH_MAGICMIME+import Magic+import Utility.Env+import Common+#else+type Magic = ()+#endif++initMagicMimeType :: IO (Maybe Magic)+#ifdef WITH_MAGICMIME+initMagicMimeType = catchMaybeIO $ do+	m <- magicOpen [MagicMimeType]+	liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case+		Nothing -> magicLoadDefault m+		Just d -> magicLoad m+			(d </> "magic" </> "magic.mgc")+	return m+#else+initMagicMimeType = return Nothing+#endif++type MimeType = String++getMagicMimeType :: Magic -> FilePath -> IO (Maybe MimeType)+#ifdef WITH_MAGICMIME+getMagicMimeType m f = Just <$> magicFile m f+#else+getMagicMimeType = return Nothing+#endif
Assistant/WebApp/Configurators/Ssh.hs view
@@ -24,10 +24,7 @@ import Git.Types (RemoteName, fromRef) import qualified Remote.GCrypt as GCrypt import qualified Annex-import qualified Git.Construct-import qualified Git.Config import qualified Git.Command-import qualified Remote.Helper.Ssh import qualified Annex.Branch import Annex.UUID import Logs.UUID
Build/Version.hs view
@@ -1,5 +1,6 @@ {- Package version determination. -} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Build.Version where@@ -13,6 +14,7 @@  import Utility.Monad import Utility.Exception+import Utility.Misc  type Version = String @@ -54,9 +56,11 @@ 	middle = drop 1 . init  writeVersion :: Version -> IO ()-writeVersion = writeFile "Build/Version" . body+writeVersion ver = catchMaybeIO (readFileStrict f) >>= \case+	Just s | s == body -> return ()+	_ -> writeFile f body   where-	body ver = unlines $ concat+	body = unlines $ concat 		[ header 		, ["packageversion :: String"] 		, ["packageversion = \"" ++ ver ++ "\""]@@ -67,3 +71,4 @@ 		, "" 		] 	footer = []+	f = "Build/Version"
CHANGELOG view
@@ -1,3 +1,18 @@+git-annex (7.20190129) upstream; urgency=medium++  * initremote S3: When configured with versioning=yes, either ask the user+    to enable bucket versioning, or auto-enable it when built with aws-0.22.+  * enableremote S3: Do not let versioning=yes be set on existing remote,+    because when git-annex lacks S3 version IDs for files stored in+    the bucket, deleting them would cause data loss.+  * S3: Detect when version=yes but an exported file lacks a S3 version ID,+    and refuse to delete it, to avoid data loss.+  * S3: Send a Content-Type header when storing objects in S3,+    so exports to public buckets can be linked to from web pages.+    (When git-annex is built with MagicMime support.)++ -- Joey Hess <id@joeyh.name>  Tue, 29 Jan 2019 15:09:20 -0400+ git-annex (7.20190122) upstream; urgency=medium    * sync --content: Fix dropping unwanted content from the local repository.
Command/Export.hs view
@@ -279,6 +279,11 @@ 	loc = mkExportLocation f' 	f' = getTopFilePath f +-- Unlike a usual drop from a repository, this does not check that+-- numcopies is satisfied before removing the content. Typically an export+-- remote is untrusted, so would not count as a copy anyway.+-- Or, an export may be appendonly, and removing a file from it does+-- not really remove the content, which must be accessible later on. performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform performUnexport r ea db eks loc = do 	ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)
Config.hs view
@@ -1,6 +1,6 @@ {- Git configuration  -- - Copyright 2011-2017 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -20,6 +20,8 @@ import Git.Types import qualified Types.Remote as Remote +import qualified Data.Map as M+ type UnqualifiedConfigKey = String data ConfigKey = ConfigKey String @@ -58,6 +60,9 @@  instance RemoteNameable Remote where 	getRemoteName = Remote.name++instance RemoteNameable Remote.RemoteConfig where+	getRemoteName c = fromMaybe "" (M.lookup "name" c)  {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
Limit.hs view
@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Limit where  import Annex.Common@@ -17,6 +15,7 @@ import Annex.WorkTree import Annex.Action import Annex.UUID+import Annex.Magic import Logs.Trust import Annex.NumCopies import Types.Key@@ -34,10 +33,6 @@ import Utility.HumanTime import Utility.DataUnits -#ifdef WITH_MAGICMIME-import Magic-#endif- import Data.Time.Clock.POSIX import qualified Data.Set as S import qualified Data.Map as M@@ -99,17 +94,16 @@ 	go (MatchingKey _ (AssociatedFile Nothing)) = pure False 	go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af -#ifdef WITH_MAGICMIME matchMagic :: Maybe Magic -> MkLimit Annex matchMagic (Just magic) glob = Right $ const go   where  	cglob = compileGlob glob CaseSensative -- memoized 	go (MatchingKey _ _) = pure False 	go (MatchingFile fi) = liftIO $ catchBoolIO $-		matchGlob cglob <$> magicFile magic (currFile fi)+		maybe False (matchGlob cglob)+			<$> getMagicMimeType magic (currFile fi) 	go (MatchingInfo _ _ _ mimeval) = matchGlob cglob <$> getInfo mimeval matchMagic Nothing _ = Left "unable to load magic database; \"mimetype\" cannot be used"-#endif  {- Adds a limit to skip files not believed to be present  - in a specfied repository. Optionally on a prior date. -}
Remote/Helper/Special.hs view
@@ -69,10 +69,8 @@ gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex () gitConfigSpecialRemote u c cfgs = do 	forM_ cfgs $ \(k, v) -> -		setConfig (remoteConfig remotename k) v-	setConfig (remoteConfig remotename "uuid") (fromUUID u)-  where-	remotename = fromJust (M.lookup "name" c)+		setConfig (remoteConfig c k) v+	setConfig (remoteConfig c "uuid") (fromUUID u)  -- RetrievalVerifiableKeysSecure unless overridden by git config. --
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes  -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -24,6 +24,7 @@ import qualified Data.Set as S import qualified System.FilePath.Posix as Posix import Data.Char+import Data.String import Network.Socket (HostName) import Network.HTTP.Conduit (Manager) import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..))@@ -47,6 +48,7 @@ import qualified Remote.Helper.AWS as AWS import Creds import Annex.UUID+import Annex.Magic import Logs.Web import Logs.MetaData import Types.MetaData@@ -74,10 +76,11 @@ gen r u c gc = do 	cst <- remoteCost gc expensiveRemoteCost 	info <- extractS3Info c-	return $ new cst info+	magic <- liftIO initMagicMimeType+	return $ new cst info magic   where-	new cst info = Just $ specialRemote c-		(prepareS3Handle this $ store this info)+	new cst info magic = Just $ specialRemote c+		(prepareS3Handle this $ store this info magic) 		(prepareS3HandleMaybe this $ retrieve this c info) 		(prepareS3Handle this $ remove info) 		(prepareS3HandleMaybe this $ checkKey this c info)@@ -99,7 +102,7 @@ 			, checkPresentCheap = False 			, exportActions = withS3HandleMaybe c gc u $ \mh ->  				return $ ExportActions-					{ storeExport = storeExportS3 u info mh+					{ storeExport = storeExportS3 u info mh magic 					, retrieveExport = retrieveExportS3 u info mh 					, removeExport = removeExportS3 u info mh 					, checkPresentExport = checkPresentExportS3 u info mh@@ -145,6 +148,7 @@ 		] 		 	use fullconfig = do+		enableBucketVersioning ss fullconfig gc u 		gitConfigSpecialRemote u fullconfig [("s3", "true")] 		return (fullconfig, u) @@ -190,16 +194,16 @@ prepareS3HandleMaybe r = resourcePrepare $ const $ 	withS3HandleMaybe (config r) (gitconfig r) (uuid r) -store :: Remote -> S3Info -> S3Handle -> Storer-store _r info h = fileStorer $ \k f p -> do-	void $ storeHelper info h f (T.pack $ bucketObject info k) p+store :: Remote -> S3Info -> Maybe Magic -> S3Handle -> Storer+store _r info magic h = fileStorer $ \k f p -> do+	void $ storeHelper info h magic f (T.pack $ bucketObject info k) p 	-- Store public URL to item in Internet Archive. 	when (isIA info && not (isChunkKey k)) $ 		setUrlPresent k (iaPublicUrl info (bucketObject info k)) 	return True -storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID)-storeHelper info h f object p = case partSize info of+storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID)+storeHelper info h magic f object p = case partSize info of 	Just partsz | partsz > 0 -> do 		fsz <- liftIO $ getFileSize f 		if fsz > partsz@@ -208,16 +212,20 @@ 	_ -> singlepartupload   where 	singlepartupload = do+		contenttype <- getcontenttype 		rbody <- liftIO $ httpBodyStorer f p-		r <- sendS3Handle h $ putObject info object rbody+		r <- sendS3Handle h $ (putObject info object rbody)+			{ S3.poContentType = encodeBS <$> contenttype } 		return (mkS3VersionID object (S3.porVersionId r)) 	multipartupload fsz partsz = do #if MIN_VERSION_aws(0,16,0)+		contenttype <- getcontenttype 		let startreq = (S3.postInitiateMultipartUpload (bucket info) object) 				{ S3.imuStorageClass = Just (storageClass info) 				, S3.imuMetadata = metaHeaders info 				, S3.imuAutoMakeBucket = isIA info 				, S3.imuExpires = Nothing -- TODO set some reasonable expiry+				, S3.imuContentType = fromString <$> contenttype 				} 		uploadid <- S3.imurUploadId <$> sendS3Handle h startreq @@ -254,6 +262,8 @@ 		warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library." 		singlepartupload #endif+	getcontenttype = liftIO $+		maybe (pure Nothing) (flip getMagicMimeType f) magic  {- Implemented as a fileRetriever, that uses conduit to stream the chunks  - out to the file. Would be better to implement a byteRetriever, but@@ -343,16 +353,16 @@ 			| otherwise = Nothing #endif -storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool-storeExportS3 u info (Just h) f k loc p = +storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportS3 u info (Just h) magic f k loc p =  	catchNonAsync go (\e -> warning (show e) >> return False)   where 	go = do 		let o = T.pack $ bucketExportLocation info loc-		storeHelper info h f o p+		storeHelper info h magic f o p 			>>= setS3VersionID info u k 		return True-storeExportS3 u _ Nothing _ _ _ _ = do+storeExportS3 u _ Nothing _ _ _ _ _ = do 	warning $ needS3Creds u 	return False @@ -373,7 +383,7 @@ 	exporturl = bucketExportLocation info loc  removeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool-removeExportS3 _u info (Just h) _k loc = +removeExportS3 u info (Just h) k loc = checkVersioning info u k $ 	catchNonAsync go (\e -> warning (show e) >> return False)   where 	go = do@@ -396,7 +406,8 @@  -- S3 has no move primitive; copy and delete. renameExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool-renameExportS3 _u info (Just h) _k src dest = catchNonAsync go (\_ -> return False)+renameExportS3 u info (Just h) k src dest = checkVersioning info u k $ +	catchNonAsync go (\_ -> return False)   where 	go = do 		let co = S3.copyObject (bucket info) dstobject@@ -416,8 +427,8 @@  - UUID file within the bucket.  -  - Some ACLs can allow read/write to buckets, but not querying them,- - so first check if the UUID file already exists and we can skip doing- - anything.+ - so first check if the UUID file already exists and we can skip creating+ - it.  -} genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex () genBucket c gc u = do@@ -848,3 +859,55 @@ getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString] getS3VersionIDPublicUrls mk info u k = 	map (s3VersionIDPublicUrl mk info) <$> getS3VersionID u k++-- Enable versioning on the bucket can only be done at init time;+-- setting versioning in a bucket that git-annex has already exported+-- files to risks losing the content of those un-versioned files.+enableBucketVersioning :: SetupStage -> RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()+#if MIN_VERSION_aws(0,22,0)+enableBucketVersioning ss c gc u = do+#else+enableBucketVersioning ss c _ _ = do+#endif+	info <- extractS3Info c+	case ss of+		Init -> when (versioning info) $+			enableversioning (bucket info)+		Enable oldc -> do+			oldinfo <- extractS3Info oldc+			when (versioning info /= versioning oldinfo) $+				giveup "Cannot change versioning= of existing S3 remote."+  where+	enableversioning b = do+#if MIN_VERSION_aws(0,22,0)+		showAction "enabling bucket versioning"+		withS3Handle c gc u $ \h ->+			void $ sendS3Handle h $ S3.putBucketVersioning b S3.VersioningEnabled+#else+		showLongNote $ unlines+			[ "This version of git-annex cannot auto-enable S3 bucket versioning."+			, "You need to manually enable versioning in the S3 console"+			, "for the bucket \"" ++ T.unpack b ++ "\""+			, "https://docs.aws.amazon.com/AmazonS3/latest/user-guide/enable-versioning.html"+			, "It's important you enable versioning before storing anything in the bucket!"+			]+#endif++-- If the remote has versioning enabled, but the version ID is for some+-- reason not being recorded, it's not safe to perform an action that+-- will remove the unversioned file. The file may be the only copy of an+-- annex object.+--+-- This code could be removed eventually, since enableBucketVersioning+-- will avoid this situation. Before that was added, some remotes+-- were created without versioning, some unversioned files exported to+-- them, and then versioning enabled, and this is to avoid data loss in+-- those cases.+checkVersioning :: S3Info -> UUID -> Key -> Annex Bool -> Annex Bool+checkVersioning info u k a+	| versioning info = getS3VersionID u k >>= \case+		[] -> do+			warning $ "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified."+			return False+		_ -> a+	| otherwise = a
doc/git-annex-export.mdwn view
@@ -41,7 +41,7 @@ However, some special remotes, notably S3, support keeping track of old versions of files stored in them. If a special remote is set up to do  that, it can be used as a key/value store and the limitations in the above-paragraph do not appy. Note that dropping content from such a remote is+paragraph do not apply. Note that dropping content from such a remote is not supported. See individual special remotes' documentation for details of how to enable such versioning.
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 7.20190122+Version: 7.20190129 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -631,6 +631,7 @@     Annex.LockFile     Annex.LockPool     Annex.LockPool.PosixOrPid+    Annex.Magic     Annex.MetaData     Annex.MetaData.StandardFields     Annex.Multicast