From 338e98c8efcbdabbe00e1f9e64f409aa64f3581a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 18 Aug 2016 15:32:31 -0400 Subject: add support for multiple storage locattions also, server upload queues in ~/.keysafe --- CmdLine.hs | 9 ++---- Storage.hs | 95 ++++++++++++++++++++++++++++++++++++++---------------- Storage/Local.hs | 48 ++++++++++++++------------- Storage/Network.hs | 7 ++-- Types/Storage.hs | 35 ++++++++++++++++++++ keysafe.cabal | 1 + keysafe.hs | 61 +++++++++++++---------------------- 7 files changed, 161 insertions(+), 95 deletions(-) create mode 100644 Types/Storage.hs diff --git a/CmdLine.hs b/CmdLine.hs index 1c0abd2..a55e985 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -11,14 +11,11 @@ import qualified Gpg import Options.Applicative import qualified Data.ByteString.UTF8 as BU8 import System.Directory -import Storage -import Storage.Local -import Storage.Network data CmdLine = CmdLine { mode :: Maybe Mode , secretkeysource :: Maybe SecretKeySource - , storage :: Storage + , localstorage :: Bool , gui :: Bool , testMode :: Bool , customShardParams :: Maybe ShardParams @@ -31,7 +28,7 @@ parse :: Parser CmdLine parse = CmdLine <$> optional (backup <|> restore <|> benchmark) <*> optional (gpgswitch <|> fileswitch) - <*> localstorageflag + <*> localstorageswitch <*> guiswitch <*> testmodeswitch <*> optional (ShardParams <$> totalobjects <*> neededobjects) @@ -58,7 +55,7 @@ parse = CmdLine <> metavar "FILE" <> help "Specify secret key file to back up or restore. (The same filename must be used to restore a key as was used to back it up.)" ) - localstorageflag = flag networkStorage localStorage + localstorageswitch = switch ( long "store-local" <> help "Store data locally, in ~/.keysafe/objects. (The default is to store data in the cloud.)" ) 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' diff --git a/Storage/Local.hs b/Storage/Local.hs index 82a7fd0..a13fcae 100644 --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -8,7 +8,7 @@ module Storage.Local (localStorage) where import Types -import Storage +import Types.Storage import Serialization () import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as U8 @@ -23,17 +23,21 @@ import Raaz.Core.Encode import Control.DeepSeq import Control.Exception -localStorage :: Storage -localStorage = Storage - { storeShard = store - , retrieveShard = retrieve - , obscureShards = obscure - , countShards = count +newtype Section = Section String + +localStorage :: String -> Storage +localStorage n = Storage + { storeShard = store section + , retrieveShard = retrieve section + , obscureShards = obscure section + , countShards = count section } + where + section = Section n -store :: StorableObjectIdent -> Shard -> IO StoreResult -store i s = onError (StoreFailure . show) $ do - dir <- shardDir +store :: Section -> StorableObjectIdent -> Shard -> IO StoreResult +store section i s = onError (StoreFailure . show) $ do + dir <- shardDir section createDirectoryIfMissing True dir let dest = dir shardFile i exists <- doesFileExist dest @@ -49,9 +53,9 @@ store i s = onError (StoreFailure . show) $ do renameFile tmp dest return StoreSuccess -retrieve :: ShardNum -> StorableObjectIdent -> IO RetrieveResult -retrieve n i = onError (RetrieveFailure . show) $ do - dir <- shardDir +retrieve :: Section -> ShardNum -> StorableObjectIdent -> IO RetrieveResult +retrieve section n i = onError (RetrieveFailure . show) $ do + dir <- shardDir section fd <- openFd (dir shardFile i) ReadOnly Nothing defaultFileFlags h <- fdToHandle fd b <- B.hGetContents h @@ -67,16 +71,16 @@ retrieve n i = onError (RetrieveFailure . show) $ do -- -- Note that the contents of shards is never changed, so it's ok to set the -- mtime to the epoch; backup programs won't be confused. -obscure :: IO ObscureResult -obscure = onError (ObscureFailure . show) $ do - dir <- shardDir +obscure :: Section -> IO ObscureResult +obscure section = onError (ObscureFailure . show) $ do + dir <- shardDir section fs <- filter isShardFile <$> getDirectoryContents dir mapM_ (\f -> setFileTimes (dir f) 0 0) fs return ObscureSuccess -count :: IO CountResult -count = onError (CountFailure . show) $ do - dir <- shardDir +count :: Section -> IO CountResult +count section = onError (CountFailure . show) $ do + dir <- shardDir section CountResult . genericLength . filter isShardFile <$> getDirectoryContents dir @@ -87,10 +91,10 @@ onError f a = do Left e -> f e Right r -> r -shardDir :: IO FilePath -shardDir = do +shardDir :: Section -> IO FilePath +shardDir (Section section) = do u <- getUserEntryForID =<< getEffectiveUserID - return $ homeDirectory u dotdir + return $ homeDirectory u dotdir section shardFile :: StorableObjectIdent -> String shardFile i = U8.toString (toByteString i) <> ext diff --git a/Storage/Network.hs b/Storage/Network.hs index 06b7545..7a461c7 100644 --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -5,10 +5,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Storage.Network (networkStorage) where +module Storage.Network (networkServers, networkStorage) where import Types -import Storage +import Types.Storage + +networkServers :: IO StorageLocations +networkServers = return $ StorageLocations [] -- none yet networkStorage :: Storage networkStorage = Storage diff --git a/Types/Storage.hs b/Types/Storage.hs new file mode 100644 index 0000000..bc11b55 --- /dev/null +++ b/Types/Storage.hs @@ -0,0 +1,35 @@ +{- Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Types.Storage where + +import Types + +-- | All known locations where shards can be stored, ordered with +-- preferred locations first. +newtype StorageLocations = StorageLocations [Storage] + deriving (Monoid) + +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. + +data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String + deriving (Show) + +data RetrieveResult = RetrieveSuccess Shard | RetrieveFailure String + +data ObscureResult = ObscureSuccess | ObscureFailure String + deriving (Show) + +data CountResult = CountResult Integer | CountFailure String + deriving (Show) diff --git a/keysafe.cabal b/keysafe.cabal index 2488c0b..0cd9bc7 100644 --- a/keysafe.cabal +++ b/keysafe.cabal @@ -74,6 +74,7 @@ Executable keysafe Tunables Types Types.Cost + Types.Storage Types.UI UI UI.Readline diff --git a/keysafe.hs b/keysafe.hs index 2ac765f..c1ed35a 100644 --- a/keysafe.hs +++ b/keysafe.hs @@ -23,10 +23,7 @@ import Data.Maybe import Data.Time.Clock import Data.Time.Calendar import Data.Monoid -import Control.Monad import Control.DeepSeq -import Control.Exception -import System.IO import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU8 import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID) @@ -42,29 +39,31 @@ main = do "Keysafe is running in test mode. This is not secure, and should not be used with real secret keys!" return (mkt testModeTunables, [mkt testModeTunables]) else return (mkt defaultTunables, map (mkt . snd) knownTunings) - dispatch cmdline ui tunables possibletunables + storagelocations <- if CmdLine.localstorage cmdline + then return localStorageLocations + else allStorageLocations + dispatch cmdline ui storagelocations tunables possibletunables -dispatch :: CmdLine.CmdLine -> UI -> Tunables -> [Tunables] -> IO () -dispatch cmdline ui tunables possibletunables = do +dispatch :: CmdLine.CmdLine -> UI -> StorageLocations -> Tunables -> [Tunables] -> IO () +dispatch cmdline ui storagelocations tunables possibletunables = do mode <- CmdLine.selectMode cmdline go mode (CmdLine.secretkeysource cmdline) where - storage = CmdLine.storage cmdline go CmdLine.Backup (Just secretkeysource) = - backup storage ui tunables secretkeysource + backup storagelocations ui tunables secretkeysource =<< getSecretKey secretkeysource go CmdLine.Restore (Just secretkeydest) = - restore storage ui possibletunables secretkeydest + restore storagelocations ui possibletunables secretkeydest go CmdLine.Backup Nothing = - backup storage ui tunables Gpg.anyKey + backup storagelocations ui tunables Gpg.anyKey =<< Gpg.getKeyToBackup ui go CmdLine.Restore Nothing = - restore storage ui possibletunables Gpg.anyKey + restore storagelocations ui possibletunables Gpg.anyKey go CmdLine.Benchmark _ = benchmarkTunables tunables -backup :: Storage -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO () -backup storage ui tunables secretkeysource secretkey = do +backup :: StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO () +backup storagelocations ui tunables secretkeysource secretkey = do username <- userName Name theirname <- fromMaybe (error "Aborting on no username") <$> promptName ui "Enter your name" @@ -84,7 +83,7 @@ backup storage ui tunables secretkeysource secretkey = do _ <- sis `deepseq` setpercent 50 let step = 50 `div` length shards let percentsteps = map setpercent [50+step, 50+step*2..100] - storeShards storage sis (zip percentsteps shards) + storeShards storagelocations sis (zip percentsteps shards) case r of StoreSuccess -> showInfo ui "Success" "Your secret key successfully encrypted and backed up." StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s) @@ -93,7 +92,7 @@ backup storage ui tunables secretkeysource secretkey = do [ "Another secret key is already being stored under the name you entered." , "Please try again with a different name." ] - backup storage ui tunables secretkeysource secretkey + backup storagelocations ui tunables secretkeysource secretkey where promptkek name = do password <- fromMaybe (error "Aborting on no password") @@ -168,8 +167,8 @@ otherNameSuggestions = unlines $ map (" * " ++) , "Your college roomate." ] -restore :: Storage -> UI -> [Tunables] -> SecretKeySource -> IO () -restore storage ui possibletunables secretkeydest = do +restore :: StorageLocations -> UI -> [Tunables] -> SecretKeySource -> IO () +restore storagelocations ui possibletunables secretkeydest = do username <- userName Name theirname <- fromMaybe (error "Aborting on no username") <$> promptName ui "Enter your name" @@ -182,7 +181,7 @@ restore storage ui possibletunables secretkeydest = do <$> promptPassword ui True "Enter password" passworddesc let mksis tunables = shardIdents tunables name secretkeydest - (tunables, shards) <- downloadShards storage ui mksis possibletunables + (tunables, shards) <- downloadShards storagelocations ui mksis possibletunables let candidatekeys = candidateKeyEncryptionKeys tunables name password let cost = getCreationCost candidatekeys @@ -222,14 +221,11 @@ restore storage ui possibletunables secretkeydest = do , "Please wait..." ] -downloadShards :: Storage -> UI -> (Tunables -> ShardIdents) -> [Tunables] -> IO (Tunables, [Shard]) -downloadShards storage ui mksis possibletunables = - bracket_ setup cleanup download +downloadShards :: StorageLocations -> UI -> (Tunables -> ShardIdents) -> [Tunables] -> IO (Tunables, [Shard]) +downloadShards storagelocations ui mksis possibletunables = + withProgress ui "Downloading encrypted data" message $ + go possibletunables where - setup = return () - download = withProgress ui "Downloading encrypted data" message (go possibletunables) - cleanup = obscureShards storage - go [] _ = return (defaultTunables, []) go (tunables:othertunables) setpercent = do let sis = mksis tunables @@ -238,19 +234,8 @@ downloadShards storage ui mksis possibletunables = -- most of the time. _ <- l `deepseq` setpercent 50 let step = 50 `div` length l - let percentsteps = [50+step, 50+step*2..100] - - mshards <- forM (zip percentsteps l) $ \(pct, (n, i)) -> do - r <- retrieveShard storage n i - case r of - RetrieveSuccess s -> do - _ <- setpercent pct - return (Just s) - RetrieveFailure f -> do - hPutStrLn stderr $ - "warning: retrieval of shard " ++ show n ++ " failed: " ++ f - return Nothing - let shards = catMaybes mshards + let percentsteps = map setpercent [50+step, 50+step*2..100] + shards <- retrieveShards storagelocations (zip percentsteps l) if null shards then go othertunables setpercent else return (tunables, shards) -- cgit v1.2.3