add ExportTree table to export db

New table needed to look up what filenames are used in the currently
exported tree, for reasons explained in export.mdwn.

Also, added smart constructors for ExportLocation and ExportDirectory to
make sure they contain filepaths with the right direction slashes.

And some code refactoring.

This commit was sponsored by Francois Marier on Patreon.

6 files changed, 17 insertions, 17 deletions

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 2d2daff39..406af0fdc 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -274,14 +274,14 @@ renameExportM d _k oldloc newloc = liftIO $ catchBoolIO $ do
 	dest = exportPath d newloc
 
 exportPath :: FilePath -> ExportLocation -> FilePath
-exportPath d (ExportLocation loc) = d </> loc
+exportPath d loc = d </> fromExportLocation loc
 
 {- Removes the ExportLocation directory and its parents, so long as
  - they're empty, up to but not including the topdir. -}
 removeExportLocation :: FilePath -> ExportLocation -> IO ()
-removeExportLocation topdir (ExportLocation loc) = go (Just loc) (Right ())
+removeExportLocation topdir loc = go (Just $ fromExportLocation loc) (Right ())
   where
 	go _ (Left _e) = return ()
 	go Nothing _ = return ()
 	go (Just loc') _ = go (upFrom loc')
-		=<< tryIO (removeDirectory $ exportPath topdir (ExportLocation loc'))
+		=<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation loc'))
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 0ddbbaf0a..77f3e837e 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -358,9 +358,9 @@ instance Proto.Serializable URI where
 	deserialize = parseURI
 
 instance Proto.Serializable ExportLocation where
-	serialize (ExportLocation loc) = loc
-	deserialize = Just . ExportLocation
+	serialize = fromExportLocation
+	deserialize = Just . mkExportLocation
 
 instance Proto.Serializable ExportDirectory where
-	serialize (ExportDirectory loc) = loc
-	deserialize = Just . ExportDirectory
+	serialize = fromExportDirectory
+	deserialize = Just . mkExportDirectory
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index df75dacd0..6f4811285 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -93,7 +93,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			-- Storing a key on an export would need a way to
 			-- look up the file(s) that the currently exported
 			-- tree uses for a key; there's not currently an
-			-- inexpensive way to do that (getExportLocation
+			-- inexpensive way to do that (getExportedLocation
 			-- only finds files that have been stored on the
 			-- export already).
 			{ storeKey = \_ _ _ -> do
@@ -105,7 +105,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			, retrieveKeyFile = \k _af dest p -> unVerified $
 				if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
 					then do
-						locs <- liftIO $ getExportLocation db k
+						locs <- liftIO $ getExportedLocation db k
 						case locs of
 							[] -> do
 								warning "unknown export location"
@@ -136,7 +136,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			, checkPresent = \k -> do
 				ea <- exportActions r
 				anyM (checkPresentExport ea k)
-					=<< liftIO (getExportLocation db k)
+					=<< liftIO (getExportedLocation db k)
 			, mkUnavailable = return Nothing
 			, getInfo = do
 				is <- getInfo r
@@ -155,10 +155,10 @@ removeEmptyDirectories ea db loc ks
 			ok <- allM (go removeexportdirectory) 
 				(reverse (exportDirectories loc))
 			unless ok $ liftIO $ do
-				-- Add back to export database, so this is
-				-- tried again next time.
+				-- Add location back to export database, 
+				-- so this is tried again next time.
 				forM_ ks $ \k ->
-					addExportLocation db k loc
+					addExportedLocation db k loc
 				flushDbQueue db
 			return ok
   where
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 398ca13b1..52d03ba94 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -615,7 +615,7 @@ getBucketObject c = munge . key2file
 		_ -> getFilePrefix c ++ s
 
 getBucketExportLocation :: RemoteConfig -> ExportLocation -> FilePath
-getBucketExportLocation c (ExportLocation loc) = getFilePrefix c ++ loc
+getBucketExportLocation c loc = getFilePrefix c ++ fromExportLocation loc
 
 {- Internet Archive documentation limits filenames to a subset of ascii.
  - While other characters seem to work now, this entity encodes everything
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 921146ebd..495b3f8fc 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -204,8 +204,8 @@ removeExportDav mh _k loc = runExport mh $ \_dav ->
 	removeHelper (exportLocation loc)
 
 removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool
-removeExportDirectoryDav mh (ExportDirectory dir) = runExport mh $ \_dav ->
-	safely (inLocation dir delContentM)
+removeExportDirectoryDav mh dir = runExport mh $ \_dav ->
+	safely (inLocation (fromExportDirectory dir) delContentM)
 		>>= maybe (return False) (const $ return True)
 
 renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs
index 09f2b1b47..cbe87e6a7 100644
--- a/Remote/WebDAV/DavLocation.hs
+++ b/Remote/WebDAV/DavLocation.hs
@@ -47,7 +47,7 @@ keyLocation :: Key -> DavLocation
 keyLocation k = keyDir k ++ keyFile k
 
 exportLocation :: ExportLocation -> DavLocation
-exportLocation (ExportLocation f) = f
+exportLocation = fromExportLocation
 
 {- Where we store temporary data for a key as it's being uploaded. -}
 keyTmpLocation :: Key -> DavLocation