export: cache connections for S3 and webdav

Command/Export.hs

@@ -89,15 +89,18 @@ seek o = do
 		-- or tag.
 		inRepo (Git.Ref.tree (exportTreeish o))
 	old <- getExport (uuid r)
-	recordExportBeginning (uuid r) new
 	db <- openDb (uuid r)
+	ea <- exportActions r
+	recordExportBeginning (uuid r) new
 	
+	liftIO $ print (old, new)
+
 	-- Clean up after incomplete export of a tree, in which
 	-- the next block of code below may have renamed some files to
 	-- temp files. Diff from the incomplete tree to the new tree,
 	-- and delete any temp files that the new tree can't use.
 	forM_ (concatMap incompleteExportedTreeish old) $ \incomplete ->
-		mapdiff (\diff -> startRecoverIncomplete r db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
+		mapdiff (\diff -> startRecoverIncomplete r ea db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
 			incomplete
 			new
 
@@ -115,15 +118,15 @@ seek o = do
 			seekdiffmap $ \(ek, (moldf, mnewf)) ->
 				case (moldf, mnewf) of
 					(Just oldf, Just _newf) ->
-						startMoveToTempName r db oldf ek
+						startMoveToTempName r ea db oldf ek
 					(Just oldf, Nothing) -> 
-						startUnexport' r db oldf ek
+						startUnexport' r ea db oldf ek
 					_ -> stop
 			-- Rename from temp to new files.
 			seekdiffmap $ \(ek, (moldf, mnewf)) ->
 				case (moldf, mnewf) of
 					(Just _oldf, Just newf) ->
-						startMoveFromTempName r db ek newf
+						startMoveFromTempName r ea db ek newf
 					_ -> stop
 		ts -> do
 			warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."
@@ -139,7 +142,7 @@ seek o = do
 				-- Don't rename to temp, because the
 				-- content is unknown; delete instead.
 				mapdiff
-					(\diff -> startUnexport r db (Git.DiffTree.file diff) (unexportboth diff))
+					(\diff -> startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))
 					oldtreesha new
 
 	-- Waiting until now to record the export guarantees that,
@@ -154,7 +157,7 @@ seek o = do
 
 	-- Export everything that is not yet exported.
 	(l, cleanup') <- inRepo $ Git.LsTree.lsTree new
-	seekActions $ pure $ map (startExport r db) l
+	seekActions $ pure $ map (startExport r ea db) l
 	void $ liftIO cleanup'
 
 	closeDb db
@@ -187,23 +190,24 @@ mkDiffMap old new = do
 		| sha == nullSha = return Nothing
 		| otherwise = Just <$> exportKey sha
 
-startExport :: Remote -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
+startExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
-startExport r db ti = do
+startExport r ea db ti = do
 	ek <- exportKey (Git.LsTree.sha ti)
 	stopUnless (liftIO $ notElem loc <$> getExportLocation db (asKey ek)) $ do
 		showStart "export" f
-		next $ performExport r db ek (Git.LsTree.sha ti) loc
+		next $ performExport r ea db ek (Git.LsTree.sha ti) loc
   where
 	loc = ExportLocation $ toInternalGitPath f
 	f = getTopFilePath $ Git.LsTree.file ti
 
-performExport :: Remote -> ExportHandle -> ExportKey -> Sha -> ExportLocation -> CommandPerform
+performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> Sha -> ExportLocation -> CommandPerform
-performExport r db ek contentsha loc = do
+performExport r ea db ek contentsha loc = do
-	let storer = storeExport $ exportActions r
+	let storer = storeExport ea
 	sent <- case ek of
 		AnnexKey k -> ifM (inAnnex k)
 			( metered Nothing k $ \m -> do
-				let rollback = void $ performUnexport r db [ek] loc
+				let rollback = void $
+					performUnexport r ea db [ek] loc
 				sendAnnex k rollback
 					(\f -> storer f k loc m)
 			, do
@@ -227,29 +231,29 @@ cleanupExport r db ek loc = do
 	logChange (asKey ek) (uuid r) InfoPresent
 	return True
 
-startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
+startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
-startUnexport r db f shas = do
+startUnexport r ea db f shas = do
 	eks <- forM (filter (/= nullSha) shas) exportKey
 	if null eks
 		then stop
 		else do
 			showStart "unexport" f'
-			next $ performUnexport r db eks loc
+			next $ performUnexport r ea db eks loc
   where
 	loc = ExportLocation $ toInternalGitPath f'
 	f' = getTopFilePath f
 
-startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
+startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startUnexport' r db f ek = do
+startUnexport' r ea db f ek = do
 	showStart "unexport" f'
-	next $ performUnexport r db [ek] loc
+	next $ performUnexport r ea db [ek] loc
   where
 	loc = ExportLocation $ toInternalGitPath f'
 	f' = getTopFilePath f
 
-performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
+performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
-performUnexport r db eks loc = do
+performUnexport r ea db eks loc = do
-	ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)
+	ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)
 		( next $ cleanupUnexport r db eks loc
 		, stop
 		)
@@ -269,47 +273,47 @@ cleanupUnexport r db eks loc = do
 			logChange (asKey ek) (uuid r) InfoMissing
 	return True
 
-startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
+startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
-startRecoverIncomplete r db sha oldf
+startRecoverIncomplete r ea db sha oldf
 	| sha == nullSha = stop
 	| otherwise = do
 		ek <- exportKey sha
 		let loc@(ExportLocation f) = exportTempName ek
 		showStart "unexport" f
 		liftIO $ removeExportLocation db (asKey ek) oldloc
-		next $ performUnexport r db [ek] loc
+		next $ performUnexport r ea db [ek] loc
   where
 	oldloc = ExportLocation $ toInternalGitPath oldf'
 	oldf' = getTopFilePath oldf
 
-startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
+startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startMoveToTempName r db f ek = do
+startMoveToTempName r ea db f ek = do
 	let tmploc@(ExportLocation tmpf) = exportTempName ek
 	showStart "rename" (f' ++ " -> " ++ tmpf)
-	next $ performRename r db ek loc tmploc
+	next $ performRename r ea db ek loc tmploc
   where
 	loc = ExportLocation $ toInternalGitPath f'
 	f' = getTopFilePath f
 
-startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
+startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
-startMoveFromTempName r db ek f = do
+startMoveFromTempName r ea db ek f = do
 	let tmploc@(ExportLocation tmpf) = exportTempName ek
 	stopUnless (liftIO $ elem tmploc <$> getExportLocation db (asKey ek)) $ do
 		showStart "rename" (tmpf ++ " -> " ++ f')
-		next $ performRename r db ek tmploc loc
+		next $ performRename r ea db ek tmploc loc
   where
 	loc = ExportLocation $ toInternalGitPath f'
 	f' = getTopFilePath f
 
-performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
+performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
-performRename r db ek src dest = do
+performRename r ea db ek src dest = do
-	ifM (renameExport (exportActions r) (asKey ek) src dest)
+	ifM (renameExport ea (asKey ek) src dest)
 		( next $ cleanupRename db ek src dest
 		-- In case the special remote does not support renaming,
 		-- unexport the src instead.
 		, do
 			warning "rename failed; deleting instead"
-			performUnexport r db [ek] src
+			performUnexport r ea db [ek] src
 		)
 
 cleanupRename :: ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup

Logs/Export.hs

@@ -24,7 +24,7 @@ data Exported = Exported
 	{ exportedTreeish :: Git.Ref
 	, incompleteExportedTreeish :: [Git.Ref]
 	}
-	deriving (Eq)
+	deriving (Eq, Show)
 
 -- | Get what's been exported to a special remote.
 --

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

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

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
+instance HasExportUnsupported (Annex (ExportActions Annex)) where
-	exportUnsupported = ExportActions
+	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 ->
+			, checkPresent = \k -> do
-				anyM (checkPresentExport (exportActions r) k)
+				ea <- exportActions r
+				anyM (checkPresentExport ea k)
 					=<< liftIO (getExportLocation db k)
 			, mkUnavailable = return Nothing
 			, getInfo = do

Remote/S3.hs

@@ -86,13 +86,14 @@ gen r u c gc = do
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, exportActions = ExportActions
+			, exportActions = withS3Handle c gc u $ \h -> 
-				{ storeExport = storeExportS3 this info
+				return $ ExportActions
-				, retrieveExport = retrieveExportS3 this info
+					{ storeExport = storeExportS3 info h
-				, removeExport = removeExportS3 this info
+					, retrieveExport = retrieveExportS3 info h
-				, checkPresentExport = checkPresentExportS3 this info
+					, removeExport = removeExportS3 info h
-				, renameExport = renameExportS3 this info
+					, 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 :: S3Info -> S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportS3 r info f _k loc p = 
+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 :: S3Info -> S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
-retrieveExportS3 r info _k loc f p =
+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 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
-removeExportS3 r info _k loc = 
+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 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
-checkPresentExportS3 r info _k loc = 
+checkPresentExportS3 info h _k loc =
-	withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
+	checkKeyHelper info h (T.pack $ bucketExportLocation info 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 :: S3Info -> S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
-renameExportS3 r info _k src dest = catchNonAsync go (\_ -> return False)
+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

Remote/WebDAV.hs

@@ -70,12 +70,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, exportActions = ExportActions
+			, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
-				{ storeExport = storeExportDav this
+				{ storeExport = storeExportDav mh
-				, retrieveExport = retrieveExportDav this
+				, retrieveExport = retrieveExportDav mh
-				, removeExport = removeExportDav this
+				, removeExport = removeExportDav mh
-				, checkPresentExport = checkPresentExportDav this
+				, checkPresentExport = checkPresentExportDav this mh
-				, renameExport = renameExportDav this
+				, 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 :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportDav r f _k loc p = runExport r $ \dav -> do
+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 :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
-retrieveExportDav r _k loc d p = runExport r $ \_dav -> do
+retrieveExportDav mh  _k loc d p = runExport mh $ \_dav -> do
 	retrieveHelper (exportLocation loc) d p
 	return True
 
-removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
+removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
-removeExportDav r _k loc = runExport r $ \_dav ->
+removeExportDav mh _k loc = runExport mh $ \_dav ->
 	removeHelper (exportLocation loc)
 
-checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
+checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
-checkPresentExportDav r _k loc = withDAVHandle r $ \mh -> case mh of
+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 :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
-renameExportDav r _k src dest = runExport r $ \dav -> do
+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 :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
-runExport r a = withDAVHandle r $ \mh -> case mh of
+runExport Nothing _ = return False
-	Nothing -> return False
+runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
-	Just h -> fromMaybe False <$> liftIO (goDAV h $ safely (a h))
 
 configUrl :: Remote -> Maybe URLString
 configUrl r = fixup <$> M.lookup "url" (config r)

Types/Remote.hs

@@ -100,7 +100,7 @@ data RemoteA a = Remote
 	-- operation.
 	, checkPresentCheap :: Bool
 	-- Some remotes support exports of trees.
-	, exportActions :: ExportActions a
+	, exportActions :: a (ExportActions a)
 	-- Some remotes can provide additional details for whereis.
 	, whereisKey :: Maybe (Key -> a [String])
 	-- Some remotes can run a fsck operation on the remote,

doc/todo/export.mdwn

@@ -48,4 +48,5 @@ Low priority:
   fails to actually delete it.
   Hypothesis: Those are done in separate http connections and it might be
   talking to two different backend servers that are out of sync.
-  So, making export cache connections might help.
+  So, making export cache connections might help. Update: No, caching
+  connections did not solve it.