S3: Allow removing files from IA, but warn about derived versions potentially still existing there.
Removal works, only derives are a potential issue, so allow removing with a warning. This way, unexporting a file works, and behavior is consistent with IA remotes whether or not exporttree=yes. Also tested exporting filenames containing unicode, spaces, underscores. All worked, despite the IA's faq saying it doesn't. This commit was sponsored by Trenton Cronholm on Patreon.
This commit is contained in:
parent
7f0e2a4685
commit
267f47c473
4 changed files with 33 additions and 23 deletions
25
Remote/S3.hs
25
Remote/S3.hs
|
@ -278,14 +278,17 @@ retrieveCheap _ _ _ = return False
|
|||
- While it may remove the file, there are generally other files
|
||||
- derived from it that it does not remove. -}
|
||||
remove :: S3Info -> S3Handle -> Remover
|
||||
remove info h k
|
||||
remove info h k = warnIARemoval info $ do
|
||||
res <- tryNonAsync $ sendS3Handle h $
|
||||
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
|
||||
return $ either (const False) (const True) res
|
||||
|
||||
warnIARemoval :: S3Info -> Annex a -> Annex a
|
||||
warnIARemoval info a
|
||||
| isIA info = do
|
||||
warning "Cannot remove content from the Internet Archive"
|
||||
return False
|
||||
| otherwise = do
|
||||
res <- tryNonAsync $ sendS3Handle h $
|
||||
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
|
||||
return $ either (const False) (const True) res
|
||||
warning "Derived versions of removed file may still be present in the Internet Archive"
|
||||
a
|
||||
| otherwise = a
|
||||
|
||||
checkKey :: Remote -> S3Info -> Maybe S3Handle -> CheckPresent
|
||||
checkKey r info Nothing k = case getpublicurl info of
|
||||
|
@ -342,7 +345,7 @@ retrieveExportS3 r info _k loc f p =
|
|||
return True
|
||||
|
||||
removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 r info _k loc =
|
||||
removeExportS3 r info _k loc = warnIARemoval info $
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
|
||||
|
@ -620,9 +623,9 @@ getBucketObject c = munge . key2file
|
|||
getBucketExportLocation :: RemoteConfig -> ExportLocation -> FilePath
|
||||
getBucketExportLocation c (ExportLocation loc) = getFilePrefix c ++ loc
|
||||
|
||||
{- Internet Archive limits filenames to a subset of ascii,
|
||||
- with no whitespace. Other characters are xml entity
|
||||
- encoded. -}
|
||||
{- Internet Archive documentation limits filenames to a subset of ascii.
|
||||
- While other characters seem to work now, this entity encodes everything
|
||||
- else to avoid problems. -}
|
||||
iaMunge :: String -> String
|
||||
iaMunge = (>>= munge)
|
||||
where
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue