improve error display when storing to an export/import remote fails

Prompted by the test suite on windows failing to with "export foo failed"
and no information about what went wrong.

Note that only storeExportWithContentIdentifier has been converted.
storeExport still returns a Bool and so exceptions may be hidden.

However, storeExportWithContentIdentifier has many more failure modes,
since it needs to avoid overwriting modified files. So it's more
important it have better error display.

Remote/Adb.hs

@@ -291,17 +291,19 @@ retrieveExportWithContentIdentifierM serial adir loc cid dest mkkey _p = catchDe
   where
 	src = androidExportLocation adir loc
 
-storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)
-storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p = catchDefaultIO Nothing $
+storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)
+storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p =
 	-- Check if overwrite is safe before sending, because sending the
 	-- file is expensive and don't want to do it unncessarily.
 	ifM checkcanoverwrite
 		( ifM (store'' serial dest src checkcanoverwrite)
-			( liftIO $ either (const Nothing) id 
-				<$> getExportContentIdentifier serial adir loc
-			, return Nothing
+			( liftIO $ getExportContentIdentifier serial adir loc >>= return . \case
+				Right (Just cid) -> Right cid
+				Right Nothing -> Left "adb failed to store file"
+				Left _ -> Left "unable to get content identifier for file stored on adtb"
+			, return $ Left "adb failed to store file"
 			)
-		, return Nothing
+		, return $ Left "unsafe to overwrite file"
 		)
   where
 	dest = androidExportLocation adir loc
@@ -377,6 +379,7 @@ mkAdbCommand :: AndroidSerial -> [CommandParam] -> [CommandParam]
 mkAdbCommand serial cmd = [Param "-s", Param (fromAndroidSerial serial)] ++ cmd
 
 -- Gets the current content identifier for a file on the android device.
+-- If the file is not present, returns Right Nothing
 getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> IO (Either ExitCode (Maybe ContentIdentifier))
 getExportContentIdentifier serial adir loc = liftIO $ do
 	ls <- adbShellRaw serial $ unwords

Remote/Directory.hs

@@ -395,20 +395,22 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
 		| currcid == Just cid = cont
 		| otherwise = return Nothing
 
-storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)
+storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)
 storeExportWithContentIdentifierM dir src _k loc overwritablecids p =
-	catchDefaultIO Nothing $ do
+	catchIO go (return . Left . show)
+  where
+	go = do
 		liftIO $ createDirectoryIfMissing True destdir
 		withTmpFileIn destdir template $ \tmpf tmph -> do
 			liftIO $ withMeteredFile src p (L.hPut tmph)
 			liftIO $ hFlush tmph
 			liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case
-				Nothing -> return Nothing
+				Nothing -> 
+					return $ Left "unable to generate content identifier"
 				Just newcid ->
-					checkExportContent dir loc (newcid:overwritablecids) Nothing $ const $ do
+					checkExportContent dir loc (newcid:overwritablecids) (Left "unsafe to overwrite file") $ const $ do
 						liftIO $ rename tmpf dest
-						return (Just newcid)
-  where
+						return (Right newcid)
 	dest = exportPath dir loc
 	(destdir, base) = splitFileName dest
 	template = relatedTemplate (base ++ ".tmp")

Remote/Helper/ExportImport.hs

@@ -57,7 +57,7 @@ instance HasImportUnsupported (ImportActions Annex) where
 	importUnsupported = ImportActions
 		{ listImportableContents = return Nothing
 		, retrieveExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing
-		, storeExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing
+		, storeExportWithContentIdentifier = \_ _ _ _ _ -> return (Left "import not supported")
 		, removeExportWithContentIdentifier = \_ _ _ -> return False
 		, removeExportDirectoryWhenEmpty = Just $ \_ -> return False
 		, checkPresentExportWithContentIdentifier = \_ _ _ -> return False
@@ -154,8 +154,10 @@ adjustExportImport r = case M.lookup "exporttree" (config r) of
 					oldcids <- liftIO $ concat
 						<$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) oldks
 					storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case
-						Nothing -> return False
-						Just newcid -> do
+						Left err -> do
+							warning err
+							return False
+						Right newcid -> do
 							withExclusiveLock gitAnnexContentIdentifierLock $ do
 								liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k
 								liftIO $ ContentIdentifier.flushDbQueue db

Remote/Helper/ReadOnly.hs

@@ -65,18 +65,17 @@ readonlyRemoveExportDirectory _ = readonlyFail
 readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
 readonlyRenameExport _ _ _ = return Nothing
 
-readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)
-readonlyStoreExportWithContentIdentifier _ _ _ _ _ = do
-	readonlyWarning
-	return Nothing
+readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)
+readonlyStoreExportWithContentIdentifier _ _ _ _ _ =
+	return $ Left readonlyWarning
 
 readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
 readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail
 
 readonlyFail :: Annex Bool
 readonlyFail = do
-	readonlyWarning
+	warning readonlyWarning
 	return False
 
-readonlyWarning :: Annex ()
-readonlyWarning = warning "this remote is readonly"
+readonlyWarning :: String
+readonlyWarning = "this remote is readonly"

Remote/S3.hs

@@ -575,7 +575,7 @@ rewritePreconditionException a = catchJust (Url.matchStatusCodeException want) a
 --
 -- When the bucket is not versioned, data loss can result.
 -- This is why that configuration requires --force to enable.
-storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)
+storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)
 storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p
 	| versioning info = go
 	-- FIXME Actual aws version that supports getting Etag for a store
@@ -584,20 +584,18 @@ storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p
 #if MIN_VERSION_aws(0,99,0)
 	| otherwise = go
 #else
-	| otherwise = do
-		warning "git-annex is built with too old a version of the aws library to support this operation"
-		return Nothing
+	| otherwise = return $
+		Left "git-annex is built with too old a version of the aws library to support this operation"
 #endif
   where
 	go = storeExportS3' hv r info magic src k loc p >>= \case
-		(False, _) -> return Nothing
-		(True, (_, Just vid)) -> return $ Just $
+		(False, _) -> return $ Left "failed to store content in S3 bucket"
+		(True, (_, Just vid)) -> return $ Right $
 			mkS3VersionedContentIdentifier vid
-		(True, (Just etag, Nothing)) -> return $ Just $
+		(True, (Just etag, Nothing)) -> return $ Right $
 			mkS3UnversionedContentIdentifier etag
-		(True, (Nothing, Nothing)) -> do
-			warning "did not get ETag for store to S3 bucket"
-			return Nothing
+		(True, (Nothing, Nothing)) -> 
+			return $ Left "did not get ETag for store to S3 bucket"
 
 -- Does not guarantee that the removed object has the content identifier,
 -- but when the bucket is versioned, the removed object content can still

Types/Remote.hs

@@ -292,7 +292,7 @@ data ImportActions a = ImportActions
 		-> [ContentIdentifier]
 		-- ^ old content that it's safe to overwrite
 		-> MeterUpdate
-		-> a (Maybe ContentIdentifier)
+		-> a (Either String ContentIdentifier)
 	-- This is used rather than removeExport when a special remote
 	-- supports imports.
 	--