untested moving of upload queues on to servers

There needs to be a 1:1 mapping between upload queues and servers,
otherwise using the upload queue risks two shards for the same object
being uploaded to the same server.

Also, fixed storeShards to give up on StoreAlreadyExists, rather than
trying another storage location. Otherwise, on a name collision,
the shards would be rejected by the servers, and be stored to their upload
queues.

2 files changed, 59 insertions, 21 deletions

diff --git a/Storage/Local.hs b/Storage/Local.hs
index a13fcae..bd49116 100644
--- a/Storage/Local.hs
+++ b/Storage/Local.hs
@@ -5,10 +5,11 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 
-module Storage.Local (localStorage) where
+module Storage.Local (localStorage, uploadQueue) where
 
 import Types
 import Types.Storage
+import Storage.Network (Server(..))
 import Serialization ()
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as U8
@@ -22,6 +23,7 @@ import System.FilePath
 import Raaz.Core.Encode
 import Control.DeepSeq
 import Control.Exception
+import Control.Monad
 
 newtype Section = Section String
 
@@ -31,10 +33,14 @@ localStorage n = Storage
 	, retrieveShard = retrieve section
 	, obscureShards = obscure section
 	, countShards = count section
+	, moveShards = move section
 	}
   where
 	section = Section n
 
+uploadQueue :: Server -> Storage
+uploadQueue s = localStorage ("uploadqueue" </> serverName s)
+
 store :: Section -> StorableObjectIdent -> Shard -> IO StoreResult
 store section i s = onError (StoreFailure . show) $ do
 	dir <- shardDir section
@@ -84,6 +90,26 @@ count section = onError (CountFailure . show) $ do
 	CountResult . genericLength . filter isShardFile
 		<$> getDirectoryContents dir
 
+move :: Section -> Storage -> IO ()
+move section storage = do
+	dir <- shardDir section
+	fs <- getDirectoryContents dir
+	forM_ fs $ \f -> case fromShardFile f of
+		Nothing -> return ()
+		Just i -> do
+			-- Use a dummy shard number of 0; it doesn't
+			-- matter because we're not going to be
+			-- recombining the shard, just sending its contents
+			-- on the the server.
+			r <- retrieve section 0 i
+			case r of
+				RetrieveFailure _ -> return ()
+				RetrieveSuccess shard -> do
+					s <- storeShard storage i shard
+					case s of
+						StoreFailure _ -> return ()
+						_ -> removeFile f
+
 onError :: (IOException -> a) -> IO a -> IO a
 onError f a = do
 	v <- try a
@@ -96,14 +122,19 @@ shardDir (Section section) = do
 	u <- getUserEntryForID =<< getEffectiveUserID
 	return $ homeDirectory u </> dotdir </> section
 
-shardFile :: StorableObjectIdent -> String
+shardFile :: StorableObjectIdent -> FilePath
 shardFile i = U8.toString (toByteString i) <> ext
 
-ext :: String
-ext = ".keysafe"
+fromShardFile :: FilePath -> Maybe StorableObjectIdent
+fromShardFile f
+	| isShardFile f = fromByteString $ U8.fromString $ dropExtension f
+	| otherwise = Nothing
 
 isShardFile :: FilePath -> Bool
 isShardFile f = ext `isSuffixOf` f
 
+ext :: String
+ext = ".keysafe"
+
 dotdir :: FilePath
 dotdir = ".keysafe" </> "objects"
diff --git a/Storage/Network.hs b/Storage/Network.hs
index 7a461c7..2b837dc 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -5,32 +5,39 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 
-module Storage.Network (networkServers, networkStorage) where
+module Storage.Network (Server(..), networkServers, networkStorage) where
 
 import Types
 import Types.Storage
 
-networkServers :: IO StorageLocations
-networkServers = return $ StorageLocations [] -- none yet
+newtype Server = Server { serverName :: String }
 
-networkStorage :: Storage
-networkStorage = Storage
-	{ storeShard = store
-	, retrieveShard = retrieve
-	, obscureShards = obscure
-	, countShards = count
+networkServers :: IO [Server]
+networkServers = return [] -- none yet
+
+networkStorage :: Server -> Storage
+networkStorage server = Storage
+	{ storeShard = store server
+	, retrieveShard = retrieve server
+	, obscureShards = obscure server
+	, countShards = count server
+	, moveShards = move server
 	}
 
-store :: StorableObjectIdent -> Shard -> IO StoreResult
-store _i _s = return $ StoreFailure "network storage not implemented yet"
+store :: Server -> StorableObjectIdent -> Shard -> IO StoreResult
+store _server _i _s = return $ StoreFailure "network storage not implemented yet"
 
-retrieve :: ShardNum -> StorableObjectIdent -> IO RetrieveResult
-retrieve _n _i = return $ RetrieveFailure "network storage not implemented yet"
+retrieve :: Server -> ShardNum -> StorableObjectIdent -> IO RetrieveResult
+retrieve _server _n _i = return $ RetrieveFailure "network storage not implemented yet"
 
 -- | Servers should automatically obscure, so do nothing.
 -- (Could upload chaff.)
-obscure :: IO ObscureResult
-obscure = return ObscureSuccess
+obscure :: Server -> IO ObscureResult
+obscure _ = return ObscureSuccess
+
+count :: Server -> IO CountResult
+count _server = return $ CountFailure "network storage not implemented yet"
 
-count :: IO CountResult
-count = return $ CountFailure "network storage not implemented yet"
+-- | Not needed for servers.
+move :: Server -> Storage -> IO ()
+move _ _ = return ()