From f938e767f36a32d52456fbdd15345b1fc26bb18d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 25 Apr 2013 15:20:31 -0400
Subject: S3: Dropping content from the Internet Archive doesn't work, but
 their API indicates it does. Always refuse to drop from there.

---
 Remote/S3.hs | 27 ++++++++++++++++-----------
 1 file changed, 16 insertions(+), 11 deletions(-)

(limited to 'Remote/S3.hs')

diff --git a/Remote/S3.hs b/Remote/S3.hs
index 72bcd1a58..7df1c2df3 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -54,7 +54,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			storeKey = store this,
 			retrieveKeyFile = retrieve this,
 			retrieveKeyFileCheap = retrieveCheap this,
-			removeKey = remove this,
+			removeKey = remove this c,
 			hasKey = checkPresent this,
 			hasKeyCheap = False,
 			whereisKey = Nothing,
@@ -68,7 +68,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 		}
 
 s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
-s3Setup u c = handlehost $ M.lookup "host" c
+s3Setup u c = if isIA c then archiveorg else defaulthost
   where
 	remotename = fromJust (M.lookup "name" c)
 	defbucket = remotename ++ "-" ++ fromUUID u
@@ -80,11 +80,6 @@ s3Setup u c = handlehost $ M.lookup "host" c
 		, ("bucket", defbucket)
 		]
 		
-	handlehost Nothing = defaulthost
-	handlehost (Just h)
-		| isIAHost h = archiveorg
-		| otherwise = defaulthost
-
 	use fullconfig = do
 		gitConfigSpecialRemote u fullconfig "s3" "true"
 		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 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
 		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) -> 
 	-- To get file size of the encrypted content, have to use a temp file.
 	-- (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) $
 			readBytes $ L.writeFile 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
 			Left e -> s3Warning e
 
-remove :: Remote -> Key -> Annex Bool
-remove r k = s3Action r False $ \(conn, bucket) -> do
+remove :: Remote -> RemoteConfig -> Key -> Annex Bool
+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
 	s3Bool res
 
@@ -276,5 +278,8 @@ s3Connection c u = go =<< getRemoteCredPairFor "S3" c (AWS.creds u)
 iaHost :: HostName
 iaHost = "s3.us.archive.org"
 
+isIA :: RemoteConfig -> Bool
+isIA c = maybe False isIAHost (M.lookup "host" c)
+
 isIAHost :: HostName -> Bool
 isIAHost h = ".archive.org" `isSuffixOf` map toLower h
-- 
cgit v1.2.3