mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

S3: Dropping content from the Internet Archive doesn't work, but their API indicates it does. Always refuse to drop from there.

Browse source
This commit is contained in:
Joey Hess 2013-04-25 15:20:31 -04:00
parent 8284b310a7
commit 3e396a3b89
2 changed files with 18 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
Remote/S3.hs
View file

@ -54,7 +54,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
storeKey = store this, storeKey = store this,
retrieveKeyFile = retrieve this, retrieveKeyFile = retrieve this,
retrieveKeyFileCheap = retrieveCheap this, retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this, removeKey = remove this c,
hasKey = checkPresent this, hasKey = checkPresent this,
hasKeyCheap = False, hasKeyCheap = False,
whereisKey = Nothing, whereisKey = Nothing,
@ -68,7 +68,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
} }
s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
s3Setup u c = handlehost $ M.lookup "host" c s3Setup u c = if isIA c then archiveorg else defaulthost
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u defbucket = remotename ++ "-" ++ fromUUID u
@ -80,11 +80,6 @@ s3Setup u c = handlehost $ M.lookup "host" c
, ("bucket", defbucket) , ("bucket", defbucket)
] ]
handlehost Nothing = defaulthost
handlehost (Just h)
| isIAHost h = archiveorg
| otherwise = defaulthost
use fullconfig = do use fullconfig = do
gitConfigSpecialRemote u fullconfig "s3" "true" gitConfigSpecialRemote u fullconfig "s3" "true"
setRemoteCredPair fullconfig (AWS.creds u) setRemoteCredPair fullconfig (AWS.creds u)
@ -116,7 +111,7 @@ s3Setup u c = handlehost $ M.lookup "host" c
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f p = s3Action r False $ \(conn, bucket) -> store r k _f p = s3Action r False $ \(conn, bucket) ->
sendAnnex k (void $ remove r k) $ \src -> do sendAnnex k (void $ remove' r k) $ \src -> do
res <- storeHelper (conn, bucket) r k p src res <- storeHelper (conn, bucket) r k p src
s3Bool res s3Bool res
@ -124,7 +119,7 @@ storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) -> storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file. -- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.) -- (An alternative would be chunking to to a constant size.)
withTmp enck $ \tmp -> sendAnnex k (void $ remove r enck) $ \src -> do withTmp enck $ \tmp -> sendAnnex k (void $ remove' r enck) $ \src -> do
liftIO $ encrypt (getGpgOpts r) cipher (feedFile src) $ liftIO $ encrypt (getGpgOpts r) cipher (feedFile src) $
readBytes $ L.writeFile tmp readBytes $ L.writeFile tmp
res <- storeHelper (conn, bucket) r enck p tmp res <- storeHelper (conn, bucket) r enck p tmp
@ -178,8 +173,15 @@ retrieveEncrypted r (cipher, enck) k d p = s3Action r False $ \(conn, bucket) ->
return True return True
Left e -> s3Warning e Left e -> s3Warning e
remove :: Remote -> Key -> Annex Bool remove :: Remote -> RemoteConfig -> Key -> Annex Bool
remove r k = s3Action r False $ \(conn, bucket) -> do remove r c k
| isIA c = do
warning "Cannot remove content from the Internet Archive"
return False
| otherwise = remove' r k
remove' :: Remote -> Key -> Annex Bool
remove' r k = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ deleteObject conn $ bucketKey r bucket k res <- liftIO $ deleteObject conn $ bucketKey r bucket k
s3Bool res s3Bool res
@ -276,5 +278,8 @@ s3Connection c u = go =<< getRemoteCredPairFor "S3" c (AWS.creds u)
iaHost :: HostName iaHost :: HostName
iaHost = "s3.us.archive.org" iaHost = "s3.us.archive.org"
isIA :: RemoteConfig -> Bool
isIA c = maybe False isIAHost (M.lookup "host" c)
isIAHost :: HostName -> Bool isIAHost :: HostName -> Bool
isIAHost h = ".archive.org" `isSuffixOf` map toLower h isIAHost h = ".archive.org" `isSuffixOf` map toLower h

2
debian/changelog vendored
View file

@ -33,6 +33,8 @@ git-annex (4.20130418) UNRELEASED; urgency=low
prefer the one with a higher trust level. prefer the one with a higher trust level.
* Add public repository group. * Add public repository group.
* webapp: Can now set up Internet Archive repositories. * webapp: Can now set up Internet Archive repositories.
* S3: Dropping content from the Internet Archive doesn't work, but
their API indicates it does. Always refuse to drop from there.
-- Joey Hess <joeyh@debian.org> Thu, 18 Apr 2013 16:22:48 -0400 -- Joey Hess <joeyh@debian.org> Thu, 18 Apr 2013 16:22:48 -0400