export: cache connections for S3 and webdav

5 files changed, 54 insertions, 51 deletions

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index c17ed80a5..c3ebeb899 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -61,7 +61,7 @@ gen r u c gc = do
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = True
-			, exportActions = ExportActions
+			, exportActions = return $ ExportActions
 				{ storeExport = storeExportDirectory dir
 				, retrieveExport = retrieveExportDirectory dir
 				, removeExport = removeExportDirectory dir
diff --git a/Remote/External.hs b/Remote/External.hs
index ed00cc93f..fd4fd0649 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -70,7 +70,7 @@ gen r u c gc
 		avail <- getAvailability external r gc
 		exportsupported <- checkExportSupported' external
 		let exportactions = if exportsupported
-			then ExportActions
+			then return $ ExportActions
 				{ storeExport = storeExportExternal external
 				, retrieveExport = retrieveExportExternal external
 				, removeExport = removeExportExternal external
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index 517b4333f..4616d4bb1 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -26,8 +26,8 @@ class HasExportUnsupported a where
 instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
 	exportUnsupported = \_ _ -> return False
 
-instance HasExportUnsupported (ExportActions Annex) where
-	exportUnsupported = ExportActions
+instance HasExportUnsupported (Annex (ExportActions Annex)) where
+	exportUnsupported = return $ ExportActions
 		{ storeExport = \_ _ _ _ -> do
 			warning "store export is unsupported"
 			return False
@@ -103,7 +103,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 							[] -> do
 								warning "unknown export location"
 								return False
-							(l:_) -> retrieveExport (exportActions r) k l dest p
+							(l:_) -> do
+								ea <- exportActions r
+								retrieveExport ea k l dest p
 					else do
 						warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
 						return False
@@ -111,8 +113,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			-- Remove all files a key was exported to.
 			, removeKey = \k -> do
 				locs <- liftIO $ getExportLocation db k
+				ea <- exportActions r
 				oks <- forM locs $ \loc -> do
-					ok <- removeExport (exportActions r) k loc
+					ok <- removeExport ea k loc
 					when ok $
 						liftIO $ removeExportLocation db k loc
 					return ok
@@ -125,8 +128,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			-- Check if any of the files a key was exported
 			-- to are present. This doesn't guarantee the
 			-- export contains the right content.
-			, checkPresent = \k ->
-				anyM (checkPresentExport (exportActions r) k)
+			, checkPresent = \k -> do
+				ea <- exportActions r
+				anyM (checkPresentExport ea k)
 					=<< liftIO (getExportLocation db k)
 			, mkUnavailable = return Nothing
 			, getInfo = do
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 77cd7f74b..8b6fe6103 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -86,13 +86,14 @@ gen r u c gc = do
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, exportActions = ExportActions
-				{ storeExport = storeExportS3 this info
-				, retrieveExport = retrieveExportS3 this info
-				, removeExport = removeExportS3 this info
-				, checkPresentExport = checkPresentExportS3 this info
-				, renameExport = renameExportS3 this info
-				}
+			, exportActions = withS3Handle c gc u $ \h -> 
+				return $ ExportActions
+					{ storeExport = storeExportS3 info h
+					, retrieveExport = retrieveExportS3 info h
+					, removeExport = removeExportS3 info h
+					, checkPresentExport = checkPresentExportS3 info h
+					, renameExport = renameExportS3 info h
+					}
 			, whereisKey = Just (getWebUrls info c)
 			, remoteFsck = Nothing
 			, repairRepo = Nothing
@@ -321,41 +322,40 @@ checkKeyHelper info h object = do
 			| otherwise = Nothing
 #endif
 
-storeExportS3 :: Remote -> S3Info -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportS3 r info f _k loc p = 
+storeExportS3 :: S3Info -> S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportS3 info h f _k loc p = 
 	catchNonAsync go (\e -> warning (show e) >> return False)
   where
-	go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
+	go = do
 		storeHelper info h f (T.pack $ bucketExportLocation info loc) p
 		return True
 
-retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
-retrieveExportS3 r info _k loc f p =
+retrieveExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportS3 info h _k loc f p =
 	catchNonAsync go (\e -> warning (show e) >> return False)
   where
-	go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
+	go = do
 		retrieveHelper info h (T.pack $ bucketExportLocation info loc) f p
 		return True
 
-removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
-removeExportS3 r info _k loc = 
+removeExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
+removeExportS3 info h _k loc = 
 	catchNonAsync go (\e -> warning (show e) >> return False)
   where
-	go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
+	go = do
 		res <- tryNonAsync $ sendS3Handle h $
 			S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
 		return $ either (const False) (const True) res
 
-checkPresentExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
-checkPresentExportS3 r info _k loc = 
-	withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
-		checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
+checkPresentExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
+checkPresentExportS3 info h _k loc =
+	checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
 
 -- S3 has no move primitive; copy and delete.
-renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
-renameExportS3 r info _k src dest = catchNonAsync go (\_ -> return False)
+renameExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportS3 info h _k src dest = catchNonAsync go (\_ -> return False)
   where
-	go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
+	go = do
 		let co = S3.copyObject (bucket info) dstobject
 			(S3.ObjectId (bucket info) srcobject Nothing)
 			S3.CopyMetadata
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 12b9d40b2..c45776a69 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -70,12 +70,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, exportActions = ExportActions
-				{ storeExport = storeExportDav this
-				, retrieveExport = retrieveExportDav this
-				, removeExport = removeExportDav this
-				, checkPresentExport = checkPresentExportDav this
-				, renameExport = renameExportDav this
+			, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
+				{ storeExport = storeExportDav mh
+				, retrieveExport = retrieveExportDav mh
+				, removeExport = removeExportDav mh
+				, checkPresentExport = checkPresentExportDav this mh
+				, renameExport = renameExportDav mh
 				}
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
@@ -178,37 +178,36 @@ checkKey r chunkconfig (Just dav) k = do
 				existsDAV (keyLocation k)
 			either giveup return v
 
-storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportDav r f _k loc p = runExport r $ \dav -> do
+storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportDav mh f _k loc p = runExport mh $ \dav -> do
 	reqbody <- liftIO $ httpBodyStorer f p
 	storeHelper dav (exportTmpLocation loc) (exportLocation loc) reqbody
 	return True
 
-retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
-retrieveExportDav r _k loc d p = runExport r $ \_dav -> do
+retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportDav mh  _k loc d p = runExport mh $ \_dav -> do
 	retrieveHelper (exportLocation loc) d p
 	return True
 
-removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
-removeExportDav r _k loc = runExport r $ \_dav ->
+removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
+removeExportDav mh _k loc = runExport mh $ \_dav ->
 	removeHelper (exportLocation loc)
 
-checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
-checkPresentExportDav r _k loc = withDAVHandle r $ \mh -> case mh of
+checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
+checkPresentExportDav r mh _k loc = case mh of
 	Nothing -> giveup $ name r ++ " not configured"
 	Just h -> liftIO $ do
 		v <- goDAV h $ existsDAV (exportLocation loc)
 		either giveup return v
 
-renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
-renameExportDav r _k src dest = runExport r $ \dav -> do
+renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportDav mh _k src dest = runExport mh $ \dav -> do
 	moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
 	return True
 
-runExport :: Remote -> (DavHandle -> DAVT IO Bool) -> Annex Bool
-runExport r a = withDAVHandle r $ \mh -> case mh of
-	Nothing -> return False
-	Just h -> fromMaybe False <$> liftIO (goDAV h $ safely (a h))
+runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
+runExport Nothing _ = return False
+runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
 
 configUrl :: Remote -> Maybe URLString
 configUrl r = fixup <$> M.lookup "url" (config r)