diff options
| -rw-r--r-- | CmdLine.hs | 8 | ||||
| -rw-r--r-- | Storage.hs | 25 | ||||
| -rw-r--r-- | Storage/Local.hs | 39 | ||||
| -rw-r--r-- | Storage/Network.hs | 41 | ||||
| -rw-r--r-- | TODO | 3 | ||||
| -rw-r--r-- | Types/Storage.hs | 13 | ||||
| -rw-r--r-- | keysafe.hs | 2 |
7 files changed, 91 insertions, 40 deletions
@@ -21,12 +21,12 @@ data CmdLine = CmdLine , customShardParams :: Maybe ShardParams } -data Mode = Backup | Restore | Benchmark +data Mode = Backup | Restore | UploadQueued | Benchmark deriving (Show) parse :: Parser CmdLine parse = CmdLine - <$> optional (backup <|> restore <|> benchmark) + <$> optional (backup <|> restore <|> uploadqueued <|> benchmark) <*> optional (gpgswitch <|> fileswitch) <*> localstorageswitch <*> guiswitch @@ -41,6 +41,10 @@ parse = CmdLine ( long "restore" <> help "Retrieve a secret key from keysafe." ) + uploadqueued = flag' UploadQueued + ( long "uploadqueued" + <> help "Upload any data to servers that was queued by a previous --backup run." + ) benchmark = flag' Benchmark ( long "benchmark" <> help "Benchmark speed of keysafe's cryptographic primitives." @@ -10,23 +10,16 @@ import Types.Storage import Shard import Storage.Local import Storage.Network -import System.FilePath import Data.Monoid import Data.Maybe +import System.FilePath +import Control.Monad allStorageLocations :: IO StorageLocations allStorageLocations = do servers <- networkServers - return $ servers <> uploadQueueLocations servers - --- | 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 -> StorageLocations -uploadQueueLocations (StorageLocations servers) = StorageLocations $ - map (localStorage . ("uploadqueue" </>) . show) - [1..length servers] + return $ StorageLocations $ + map networkStorage servers <> map uploadQueue servers localStorageLocations :: StorageLocations localStorageLocations = StorageLocations $ @@ -52,7 +45,10 @@ storeShards (StorageLocations locs) sis shards = do StoreSuccess -> do _ <- showprogress go otherlocs (loc:usedlocs) Nothing rest - _ -> go otherlocs usedlocs (Just r) tostore + StoreFailure _ -> go otherlocs usedlocs (Just r) tostore + -- Give up if any location complains a shard + -- already exists, because we have a name conflict. + StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs) -- | Retrieves shards from among the storage locations, and returns all -- the shards it can find, which may not be all that were requested. @@ -84,3 +80,8 @@ retrieveShards (StorageLocations locs) l = do -- all shards and so learn the idents of -- all of them. go (unusedlocs++[loc]) usedlocs' rest shards' + +uploadQueued :: IO () +uploadQueued = do + servers <- networkServers + forM_ servers $ \s -> moveShards (uploadQueue s) (networkStorage s) 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 () @@ -1,8 +1,7 @@ * splitting large secret keys * tune hashes on more powerful hardware than thermal throttling laptop * store to servers -* Run periodically and store any objects in uploadqueue on servers, - to recover from eg network failure. +* Run --uploadqueued periodically (systemd timer?) * improve restore progress bar points (update after every hash try) * Keep secret keys in locked memory until they're encrypted. (Raaz makes this possible to do.) diff --git a/Types/Storage.hs b/Types/Storage.hs index bc11b55..b3f714a 100644 --- a/Types/Storage.hs +++ b/Types/Storage.hs @@ -14,14 +14,21 @@ import Types newtype StorageLocations = StorageLocations [Storage] deriving (Monoid) +-- | Storage interface. This can be used both for local storage, +-- an upload queue, or a remote server. +-- +-- Note that there is no interface to enumerate shards. +-- This is intentional; servers should not allow that. 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 + -- ^ Run after making some calls to storeShard/retrieveShard, + -- to avoid correlation attacks. , countShards :: IO CountResult - } -- Note that there is no interface to enumerate shards. + , moveShards :: Storage -> IO () + -- ^ Tries to move all shards from this storage to another one. + } data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String deriving (Show) @@ -59,6 +59,8 @@ dispatch cmdline ui storagelocations tunables possibletunables = do =<< Gpg.getKeyToBackup ui go CmdLine.Restore Nothing = restore storagelocations ui possibletunables Gpg.anyKey + go CmdLine.UploadQueued _ = + uploadQueued go CmdLine.Benchmark _ = benchmarkTunables tunables |