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:
Joey Hess 2017-09-12 12:33:08 -04:00
parent 7f0e2a4685
commit 267f47c473
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 33 additions and 23 deletions

View file

@ -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