diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -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) ] diff --git a/Annex/Magic.hs b/Annex/Magic.hs new file mode 100644 --- /dev/null +++ b/Annex/Magic.hs @@ -0,0 +1,45 @@ +{- Interface to libmagic + - + - Copyright 2019 Joey Hess + - + - 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 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 @@ -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 diff --git a/Build/Version.hs b/Build/Version.hs --- a/Build/Version.hs +++ b/Build/Version.hs @@ -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" diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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. diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -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) diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -1,6 +1,6 @@ {- Git configuration - - - Copyright 2011-2017 Joey Hess + - Copyright 2011-2019 Joey Hess - - 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 diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -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. -} diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -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. -- diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - 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 diff --git a/doc/git-annex-export.mdwn b/doc/git-annex-export.mdwn --- a/doc/git-annex-export.mdwn +++ b/doc/git-annex-export.mdwn @@ -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. 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: 7.20190122 +Version: 7.20190129 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -631,6 +631,7 @@ Annex.LockFile Annex.LockPool Annex.LockPool.PosixOrPid + Annex.Magic Annex.MetaData Annex.MetaData.StandardFields Annex.Multicast