S3: Send git-annex or other configured User-Agent.
--user-agent is the only way to configure it currently (Needs aws-0.24.3)
This commit is contained in:
parent
3f7953869d
commit
44da423e2e
5 changed files with 34 additions and 8 deletions
22
Remote/S3.hs
22
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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue