From a1d5de397cd1b12080e4652965591827e6d50c86 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Sep 2016 14:11:32 -0400 Subject: Randomize the server list. May help avoid some correlations. Once there are many servers, will spread the load out amoung them. This commit was sponsored by Ethan Aubin. --- CHANGELOG | 1 + Servers.hs | 22 +++++++++++++++------- Storage.hs | 10 +++++----- TODO | 1 - Types/Server.hs | 3 ++- keysafe.cabal | 2 ++ keysafe.hs | 19 ++++++++++--------- 7 files changed, 35 insertions(+), 23 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index dffd5eb..2e5e37e 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -4,6 +4,7 @@ keysafe (0.20160923) UNRELEASED; urgency=medium * Added --chaff-max-delay option for slower chaffing. * Fix embedded copy of Argon2 to not use Word64, fixing build on 32 bit systems. + * Randomize the server list. -- Joey Hess Fri, 23 Sep 2016 10:40:55 -0400 diff --git a/Servers.hs b/Servers.hs index d12fc56..7edc7af 100644 --- a/Servers.hs +++ b/Servers.hs @@ -7,6 +7,7 @@ module Servers where import Types.Server import Servant.Client +import System.Random.Shuffle serverUrls :: Server -> [BaseUrl] serverUrls srv = map go (serverAddress srv) @@ -17,15 +18,22 @@ networkServers :: [Server] networkServers = [ Server (ServerName "keysafe.joeyh.name") Alternate [ServerAddress "vzgrspuxbtnlrtup.onion" 4242] + "Provided by Joey Hess. Digital Ocean VPS, located in Indonesia" - -- Purism server is not yet deployed, but planned. , Server (ServerName "keysafe.puri.sm") Alternate [] + "Purism server is not yet deployed, but planned." - -- Unknown yet who will provide this server, but allocate it now - -- so keysafe can start queuing uploads to it. - , Server (ServerName "thirdserver") Recommended - [] - -- [ServerAddress "eqi7glyxe5ravak5.onion" 4242] - -- -- ^ still being vetted + -- Provided by https://faelix.net/ + -- Marek Isalski + , Server (ServerName "thirdserver") Alternate -- still being vetted + [ServerAddress "eqi7glyxe5ravak5.onion" 4242] + "Provided by Marek Isalski at Faelix. Currently located in UK, but planned move to CH" ] + +-- | Shuffles the server list, keeping Recommended first, then +-- Alternate, and finally Untrusted. +shuffleServers :: [Server] -> IO [Server] +shuffleServers l = concat <$> mapM shuf [minBound..maxBound] + where + shuf sl = shuffleM (filter (\s -> serverLevel s == sl) l) diff --git a/Storage.hs b/Storage.hs index b40a84a..c082c38 100644 --- a/Storage.hs +++ b/Storage.hs @@ -29,9 +29,9 @@ import Control.Concurrent.Async import qualified Data.Set as S import Network.Wai.Handler.Warp (Port) -networkStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations -networkStorageLocations d = StorageLocations $ - map (networkStorage d) networkServers +networkStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations +networkStorageLocations d = StorageLocations . map (networkStorage d) + <$> shuffleServers networkServers localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations localStorageLocations d = StorageLocations $ @@ -125,12 +125,12 @@ retrieveShares (StorageLocations locs) sis updateprogress = do -- | Returns descriptions of any failures. tryUploadQueued :: Maybe LocalStorageDirectory -> IO [String] tryUploadQueued d = do + StorageLocations locs <- networkStorageLocations d results <- forM locs $ \loc -> case uploadQueue loc of Nothing -> return [] Just q -> moveShares q loc return $ processresults (concat results) [] where - StorageLocations locs = networkStorageLocations d processresults [] c = nub c processresults (StoreSuccess:rs) c = processresults rs c processresults (StoreFailure e:rs) c = processresults rs (e:c) @@ -152,7 +152,7 @@ storeChaff hn port delayseconds = forever $ do [1..totalObjects (shareParams testModeTunables)] where server = networkStorage Nothing $ - Server (ServerName hn) Untrusted [ServerAddress hn port] + Server (ServerName hn) Untrusted [ServerAddress hn port] "chaff server" objsize = objectSize defaultTunables * shareOverhead defaultTunables maxmsdelay = ceiling $ 1000000 * fromMaybe 0 delayseconds go sis rng n = do diff --git a/TODO b/TODO index d0a2932..4601942 100644 --- a/TODO +++ b/TODO @@ -7,7 +7,6 @@ Later: * The attack cost display can lead to a false sense of security if the user takes it as gospel. It needs to be clear that it's an estimate. This and other parts of the keysafe UI need usability testing. -* Implement the different categories of servers in the server list. * improve restore progress bar points (update after every hash try) * If we retrieved enough shares successfully, but decrypt failed, must be a wrong password, so prompt for re-entry and retry with those shares. diff --git a/Types/Server.hs b/Types/Server.hs index 7be29ce..785dd24 100644 --- a/Types/Server.hs +++ b/Types/Server.hs @@ -28,12 +28,13 @@ instance ToJSON ServerName instance FromJSON ServerName data ServerLevel = Recommended | Alternate | Untrusted - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Bounded, Enum) data Server = Server { serverName :: ServerName , serverLevel :: ServerLevel , serverAddress :: [ServerAddress] -- ^ A server may have multiple addresses, or no current address. + , serverDesc :: String } deriving (Show, Eq, Ord) diff --git a/keysafe.cabal b/keysafe.cabal index 10061ed..538a694 100644 --- a/keysafe.cabal +++ b/keysafe.cabal @@ -72,6 +72,8 @@ Executable keysafe , async == 2.1.* , unix-compat == 0.4.* , exceptions == 0.8.* + , random-shuffle == 0.0.* + , MonadRandom == 0.4.* -- Temporarily inlined due to FTBFS bug -- https://github.com/ocharles/argon2/issues/2 -- argon2 == 1.1.* diff --git a/keysafe.hs b/keysafe.hs index f4ee878..ed7b3c4 100644 --- a/keysafe.hs +++ b/keysafe.hs @@ -114,7 +114,8 @@ backup cmdline ui tunables secretkeysource secretkey = do _ <- esk `deepseq` addpercent 25 _ <- sis `seq` addpercent 25 let step = 50 `div` sum (map S.size shares) - storeShares (cmdLineStorageLocations cmdline) sis shares (addpercent step) + locs <- cmdLineStorageLocations cmdline + storeShares locs sis shares (addpercent step) backuplog <- mkBackupLog $ backupMade (mapMaybe getServer locs) secretkeysource passwordentropy case r of StoreSuccess -> do @@ -224,7 +225,8 @@ restore cmdline ui possibletunables secretkeydest = do <$> promptPassword ui True "Enter password" passworddesc let mksis tunables = shareIdents tunables name secretkeydest - r <- downloadInitialShares storagelocations ui mksis possibletunables + locs <- cmdLineStorageLocations cmdline + r <- downloadInitialShares locs ui mksis possibletunables case r of Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name?" Just (tunables, shares, sis, usedservers) -> do @@ -236,12 +238,11 @@ restore cmdline ui possibletunables secretkeydest = do Right esk -> do final <- withProgress ui "Decrypting" (decryptdesc cost cores) $ \setpercent -> - go tunables [shares] usedservers sis setpercent $ + go locs tunables [shares] usedservers sis setpercent $ tryDecrypt candidatekeys esk final =<< getPasswordEntropy password name where - storagelocations = cmdLineStorageLocations cmdline - go tunables firstshares firstusedservers sis setpercent r = case r of + go locs tunables firstshares firstusedservers sis setpercent r = case r of DecryptFailed -> return $ \_ -> showError ui "Decryption failed! Probably you entered the wrong password." DecryptSuccess secretkey -> do @@ -257,13 +258,13 @@ restore cmdline ui possibletunables secretkeydest = do DecryptIncomplete kek -> do -- Download shares for another chunk. (nextshares, sis', nextusedservers) - <- retrieveShares storagelocations sis (return ()) + <- retrieveShares locs sis (return ()) let shares = firstshares ++ [nextshares] let usedservers = nub (firstusedservers ++ nextusedservers) case combineShares tunables shares of Left e -> return $ \_ -> showError ui e Right esk -> - go tunables shares usedservers sis' setpercent $ + go locs tunables shares usedservers sis' setpercent $ decrypt kek esk namedesc = unlines [ "When you backed up your secret key, you entered some information." @@ -337,9 +338,9 @@ userName = do u <- getUserEntryForID =<< getEffectiveUserID return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u) -cmdLineStorageLocations :: CmdLine.CmdLine -> StorageLocations +cmdLineStorageLocations :: CmdLine.CmdLine -> IO StorageLocations cmdLineStorageLocations cmdline - | CmdLine.localstorage cmdline = localStorageLocations lsd + | CmdLine.localstorage cmdline = return (localStorageLocations lsd) | otherwise = networkStorageLocations lsd where lsd = CmdLine.localstoragedirectory cmdline -- cgit v1.2.3