From 9d71858c598e6ccaf260fef3d1e90c1e3ea44775 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 6 Oct 2016 16:57:18 -0400
Subject: Check if --store-local directory is writable.

If run with --totalshares larger than the number of servers, and the
--store-local directory is not writable, this causes keysafe to throw out
the unwritable directory and so error out early due to their not being
enough storage locations.

That's better than the old behavior, which was to try to use the
--store-local directory, fail and so proceed to storing the share on a
server. That would eventually fail with "no storage locations" when it runs
out of servers. That was bad, because shares were uploaded to servers, but
perhaps not enough for restore to work, and a new name/othername would be
needed to re-run the backup.

This is not a perfect fix; if the --store-local directory is writable at
first but for some reason the write of the share to it later fails, the
situation described above still happens.

This commit was sponsored by Jochen Bartl on Patreon.
---
 Storage/Local.hs   | 23 ++++++++++++++++++-----
 Storage/Network.hs | 13 +++++++------
 2 files changed, 25 insertions(+), 11 deletions(-)

(limited to 'Storage')

diff --git a/Storage/Local.hs b/Storage/Local.hs
index a79cc43..cac12b3 100644
--- a/Storage/Local.hs
+++ b/Storage/Local.hs
@@ -14,6 +14,7 @@ module Storage.Local
 
 import Types
 import Types.Storage
+import Output
 import Serialization ()
 import Utility.UserInfo
 import Utility.Exception
@@ -50,8 +51,17 @@ localStorage storagelevel getsharedir n = Storage
   where
 	section = Section n
 
-localStorageOverride :: FilePath -> Storage
-localStorageOverride d = localStorage LocallyPreferred (\_ -> pure  d) ""
+localStorageOverride :: FilePath -> IO (Maybe Storage)
+localStorageOverride d = onError' accesserror $ do
+	-- Check that the directory can be written to.
+	createDirectoryIfMissing True d
+	writeFile (d </> "test.keysafe") "test"
+	removeFile (d </> "test.keysafe")
+	return $ Just $ localStorage LocallyPreferred (\_ -> pure d) ""
+  where
+	accesserror e = do
+		warn $ "Unable to access local storage directory " ++ d ++ " (" ++ show e ++ ")"
+		return Nothing
 
 store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult
 store section getsharedir i s = onError (StoreFailure . show) $ do
@@ -141,11 +151,14 @@ move section getsharedir storage = do
 			_ -> return StoreAlreadyExists
 
 onError :: (IOException -> a) -> IO a -> IO a
-onError f a = do
+onError f = onError' (pure . f)
+
+onError' :: (IOException -> IO a) -> IO a -> IO a
+onError' f a = do
 	v <- try a
-	return $ case v of
+	case v of
 		Left e -> f e
-		Right r -> r
+		Right r -> return r
 
 storageDir :: Maybe LocalStorageDirectory -> GetShareDir
 storageDir Nothing (Section section) = do
diff --git a/Storage/Network.hs b/Storage/Network.hs
index 9d54a1c..41d1ff1 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -33,12 +33,13 @@ networkStorage storagelevel localdir server = Storage
   where
 	ServerName name = serverName server
 
-networkStorageOverride :: Maybe LocalStorageDirectory -> HostName -> Port -> Storage
-networkStorageOverride lsd h p = networkStorage LocallyPreferred lsd $ Server
-	{ serverName = ServerName h
-	, serverAddress = [ServerAddress h p]
-	, serverDesc = h
-	}
+networkStorageOverride :: Maybe LocalStorageDirectory -> HostName -> Port -> IO (Maybe Storage)
+networkStorageOverride lsd h p = return $ Just $
+	networkStorage LocallyPreferred lsd $ Server
+		{ serverName = ServerName h
+		, serverAddress = [ServerAddress h p]
+		, serverDesc = h
+		}
 
 store :: Server -> StorableObjectIdent -> Share -> IO StoreResult
 store srv i (Share _n o) = 
-- 
cgit v1.2.3