From 338e98c8efcbdabbe00e1f9e64f409aa64f3581a Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 18 Aug 2016 15:32:31 -0400
Subject: add support for multiple storage locattions

also, server upload queues in ~/.keysafe
---
 Storage.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 68 insertions(+), 27 deletions(-)

(limited to 'Storage.hs')

diff --git a/Storage.hs b/Storage.hs
index d1a3ad8..c80935f 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -3,41 +3,82 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module Storage where
+module Storage (module Storage, module Types.Storage) where
 
 import Types
+import Types.Storage
 import Shard
+import Storage.Local
+import Storage.Network
+import System.FilePath
+import Data.Monoid
+import Data.Maybe
 
-data Storage = Storage
-	{ storeShard :: StorableObjectIdent -> Shard -> IO StoreResult
-	, retrieveShard :: ShardNum -> StorableObjectIdent -> IO RetrieveResult
-	, obscureShards :: IO ObscureResult
-	-- ^ run after making some calls to storeShard/retrieveShard,
-	-- to avoid correlation attacks
-	, countShards :: IO CountResult
-	} -- Note that there is no interface to enumerate shards.
+allStorageLocations :: IO StorageLocations
+allStorageLocations = do
+	servers <- networkServers
+	return $ servers <> uploadQueueLocations
 
-data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String
-	deriving (Show)
+-- | Objects queued for upload to servers. There are a number of queues,
+-- but no 1:1 mapping from queues to a particular server. 
+-- It's important that when flushing the upload queue, the objects in each
+-- separate queue are sent to a separate server.
+uploadQueueLocations :: StorageLocations
+uploadQueueLocations = StorageLocations $
+	map (localStorage . ("uploadqueue" </>) . show) ([1..] :: [Integer])
 
-data RetrieveResult = RetrieveSuccess Shard | RetrieveFailure String
+localStorageLocations :: StorageLocations
+localStorageLocations = StorageLocations $
+	map (localStorage . ("local" </>) . show) ([1..] :: [Integer])
 
-data ObscureResult = ObscureSuccess | ObscureFailure String
-	deriving (Show)
+type UpdateProgress = IO ()
 
-data CountResult = CountResult Integer | CountFailure String
-	deriving (Show)
-
-storeShards :: Storage -> ShardIdents -> [(IO (), Shard)] -> IO StoreResult
-storeShards storage sis shards = do
-	r <- go (zip (getIdents sis) shards)
-	_ <- obscureShards storage
+-- | Stores the shards amoung the storage locations. Each location
+-- gets at most one shard.
+storeShards :: StorageLocations -> ShardIdents -> [(UpdateProgress, Shard)] -> IO StoreResult
+storeShards (StorageLocations locs) sis shards = do
+	(r, usedlocs) <- go locs [] Nothing (zip (getIdents sis) shards)
+	_ <- mapM_ obscureShards usedlocs
 	return r
   where
-	go [] = return StoreSuccess
-	go ((i,(showprogress, s)):rest) = do
-		r <- storeShard storage i s
-		_ <- showprogress
+	go _ usedlocs _ [] = return (StoreSuccess, usedlocs)
+	go [] usedlocs lasterr _ =
+		return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs)
+	go (loc:otherlocs) usedlocs _ tostore@((i,(showprogress, s)):rest) = do
+		r <- storeShard loc i s
+		case r of
+			StoreSuccess -> do
+				_ <- showprogress
+				go otherlocs (loc:usedlocs) Nothing rest
+			_ -> go otherlocs usedlocs (Just r) tostore
+
+-- | Retrieves shards from among the storage locations, and returns all
+-- the shards it can find, which may not be all that were requested.
+--
+-- Assumes that each location only contains one shard. So, once a
+-- shard has been found on a location, can avoid asking that location
+-- for any other shards.
+retrieveShards :: StorageLocations -> [(UpdateProgress, (ShardNum, StorableObjectIdent))] -> IO [Shard]
+retrieveShards (StorageLocations locs) l = do
+	(shards, usedlocs, _unusedlocs) <- go locs [] l []
+	_ <- mapM_ obscureShards usedlocs
+	return shards
+  where
+	go unusedlocs usedlocs [] shards = return (shards, usedlocs, unusedlocs)
+	go [] usedlocs _ shards = return (shards, usedlocs, [])
+	go (loc:otherlocs) usedlocs toretrieve@((updateprogress, (n, i)):rest) shards = do
+		r <- retrieveShard loc n i
 		case r of
-			StoreSuccess -> go rest
-			_ -> return r
+			RetrieveSuccess s -> do
+				_ <- updateprogress
+				go otherlocs (loc:usedlocs) rest (s:shards)
+			RetrieveFailure _ -> do
+				(shards', usedlocs', unusedlocs) <-
+					go otherlocs usedlocs toretrieve shards
+				-- May need to ask the location that didn't
+				-- have the shard for a later shard, but
+				-- ask it last. This way, the first
+				-- location on the list can't deny having
+				-- all shards and so learn the idents of
+				-- all of them.
+				go (unusedlocs++[loc]) usedlocs' toretrieve shards'
-- 
cgit v1.2.3