Merge branch 'checkbucketversioning'

CHANGELOG

@@ -7,6 +7,10 @@ git-annex (10.20241032) UNRELEASED; urgency=medium
     when ran inside that dotdir.
   * add: When adding a dotfile as a non-large file, mention that it's a
     dotfile.
+  * S3: Support versioning=yes with a readonly bucket.
+    (Needs aws-0.24.3)
+  * S3: Send git-annex or other configured User-Agent.
+    (Needs aws-0.24.3)
 
  -- Joey Hess <id@joeyh.name>  Mon, 11 Nov 2024 12:26:00 -0400
 

Remote/S3.hs

@@ -63,8 +63,8 @@ import Utility.Metered
 import Utility.DataUnits
 import Annex.Content
 import qualified Annex.Url as Url
-import Utility.Url (extractFromResourceT)
-import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..))
+import Utility.Url (extractFromResourceT, UserAgent)
+import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..))
 import Utility.Env
 import Annex.Verify
 
@@ -885,10 +885,11 @@ mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $
 				Just creds -> go =<< liftIO (genCredentials creds)
 				Nothing -> return (Left S3HandleNeedCreds)
   where
-	s3cfg = s3Configuration c
 	go awscreds = do
-		let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing
 		ou <- getUrlOptions
+		ua <- getUserAgent
+		let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing
+		let s3cfg = s3Configuration (Just ua) c
 		return $ Right $ S3Handle (httpManager ou) awscfg s3cfg
 
 withS3Handle :: S3HandleVar -> (Either S3HandleProblem S3Handle -> Annex a) -> Annex a
@@ -907,13 +908,20 @@ withS3HandleOrFail u hv a = withS3Handle hv $ \case
 needS3Creds :: UUID -> String
 needS3Creds u = missingCredPairFor "S3" (AWS.creds u)
 
-s3Configuration :: ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery
-s3Configuration c = cfg
+s3Configuration :: Maybe UserAgent -> ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery
+#if MIN_VERSION_aws(0,24,3)
+s3Configuration ua c = cfg
+#else
+s3Configuration _ua c = cfg
+#endif
 	{ S3.s3Port = port
 	, S3.s3RequestStyle = case getRemoteConfigValue requeststyleField c of
 		Just "path" -> S3.PathStyle
 		Just s -> giveup $ "bad S3 requeststyle value: " ++ s
 		Nothing -> S3.s3RequestStyle cfg
+#if MIN_VERSION_aws(0,24,3)
+	, S3.s3UserAgent = T.pack <$> ua
+#endif
 	}
   where
 	h = fromJust $ getRemoteConfigValue hostField c
@@ -1157,7 +1165,7 @@ s3Info c info = catMaybes
 	, Just ("versioning", if versioning info then "yes" else "no")
 	]
   where
-	s3c = s3Configuration c
+	s3c = s3Configuration Nothing c
 	showstorageclass (S3.OtherStorageClass t) = T.unpack t
 	showstorageclass sc = show sc
 
@@ -1341,11 +1349,24 @@ enableBucketVersioning ss info _ _ _ = do
   where
 	enableversioning b = do
 #if MIN_VERSION_aws(0,21,1)
-		showAction "enabling bucket versioning"
+		showAction "checking bucket versioning"
 		hdl <- mkS3HandleVar c gc u
+		let setversioning = S3.putBucketVersioning b S3.VersioningEnabled
 		withS3HandleOrFail u hdl $ \h ->
-			void $ liftIO $ runResourceT $ sendS3Handle h $
-				S3.putBucketVersioning b S3.VersioningEnabled
+#if MIN_VERSION_aws(0,24,3)
+			liftIO $ runResourceT $
+				tryS3 (sendS3Handle h setversioning) >>= \case
+					Right _ -> return ()
+					Left err -> do
+						res <- sendS3Handle h $
+							S3.getBucketVersioning b
+						case S3.gbvVersioning res of
+							Just S3.VersioningEnabled -> return ()
+							_ -> giveup $ "This bucket does not have versioning enabled, and enabling it failed: "
+								++ T.unpack (S3.s3ErrorMessage err)
+#else
+			void $ liftIO $ runResourceT $ sendS3Handle h setversioning
+#endif
 #else
 		showLongNote $ unlines
 			[ "This version of git-annex cannot auto-enable S3 bucket versioning."

doc/bugs/User-Agent_not_sent_with_S3_remote.mdwn

@@ -1,3 +1,5 @@
 ### Please describe the problem.
 
 git-annex does not appear to send a User-Agent when used with an S3 remote.
+
+> [[fixed|done]] --[[Joey]]

doc/bugs/User-Agent_not_sent_with_S3_remote/comment_2_18f895b9e38908faecfc0a55a802fdd3._comment

@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 2"""
+ date="2024-11-13T19:52:28Z"
+ content="""
+Drat, no followup. I seem to remember hearing about a S3 implementation
+that either needed any User-Agent header (currently, git-annex does not
+send one to S3), or perhaps a specific User-Agent. But I don't remember
+details.
+
+Anyway, I have implemented a patch to the aws library that can be used for
+this.
+"""]]

doc/git-annex-common-options.mdwn

@@ -133,7 +133,8 @@ Most of these options are accepted by all git-annex commands.
 
 * `--user-agent=value`
 
-  Overrides the User-Agent to use when downloading files from the web.
+  Overrides the User-Agent to use when downloading files from the web,
+  or otherwise accessing web services.
 
 * `--notify-finish`
 

stack.yaml

@@ -16,3 +16,4 @@ packages:
 resolver: nightly-2024-07-29
 extra-deps:
 - filepath-bytestring-1.4.100.3.2
+- aws-0.24.3