From b40d441c52f37584653e74fada9906cc8105c9f7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 6 Oct 2016 13:54:52 -0400 Subject: move level from Server to Storage This allows local storage locations to have levels too, and also get shuffled nicely. This commit was sponsored by Ethan Aubin. --- HTTP/Client.hs | 6 +++++- HTTP/Server.hs | 2 +- Servers.hs | 27 +++++++++------------------ Storage.hs | 29 +++++++++++++++-------------- Storage/Local.hs | 5 +++-- Storage/Network.hs | 7 ++++--- Tests.hs | 2 +- Types/Server.hs | 4 ---- Types/Storage.hs | 4 ++++ keysafe.hs | 21 +++++++++------------ 10 files changed, 51 insertions(+), 56 deletions(-) diff --git a/HTTP/Client.hs b/HTTP/Client.hs index 50c5906..8415b2f 100644 --- a/HTTP/Client.hs +++ b/HTTP/Client.hs @@ -9,7 +9,6 @@ import HTTP import HTTP.ProofOfWork import Types import Types.Server -import Servers import Types.Storage import Types.Cost import Servant.API @@ -111,3 +110,8 @@ socketConnection socket chunksize = makeConnection (recv socket chunksize) (sendAll socket) (Network.Socket.close socket) + +serverUrls :: Server -> [BaseUrl] +serverUrls srv = map go (serverAddress srv) + where + go (ServerAddress addr port) = BaseUrl Http addr port "" diff --git a/HTTP/Server.hs b/HTTP/Server.hs index 886fe6f..6fd570d 100644 --- a/HTTP/Server.hs +++ b/HTTP/Server.hs @@ -56,7 +56,7 @@ runServer d cfg = do host = fromString (serverAddress cfg) serverStorage :: Maybe LocalStorageDirectory -> Storage -serverStorage d = localStorage (storageDir d) "server" +serverStorage d = localStorage LocallyPreferred (storageDir d) "server" app :: ServerState -> Application app st = serve userAPI (server st) diff --git a/Servers.hs b/Servers.hs index 08789ce..ab31838 100644 --- a/Servers.hs +++ b/Servers.hs @@ -6,8 +6,8 @@ module Servers where import Types.Server -import Servant.Client -import System.Random.Shuffle +import Types.Storage +import Storage.Network -- | Keysafe's server list. -- @@ -17,29 +17,20 @@ import System.Random.Shuffle -- -- Also, avoid changing the ServerName of any server, as that will -- cause any uploads queued under that name to not go through. -networkServers :: [Server] -networkServers = - [ Server (ServerName "keysafe.joeyh.name") Alternate +serverList :: Maybe LocalStorageDirectory -> [Storage] +serverList d = + [ mk Alternate $ Server (ServerName "keysafe.joeyh.name") [ServerAddress "vzgrspuxbtnlrtup.onion" 4242] "Provided by Joey Hess. Digital Ocean VPS, located in Indonesia" - , Server (ServerName "keysafe.puri.sm") Alternate + , mk Alternate $ Server (ServerName "keysafe.puri.sm") [] "Purism server is not yet deployed, but planned." - , Server (ServerName "thirdserver") Alternate -- still being vetted + -- still being vetted + , mk Alternate $ Server (ServerName "thirdserver") [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) - -serverUrls :: Server -> [BaseUrl] -serverUrls srv = map go (serverAddress srv) where - go (ServerAddress addr port) = BaseUrl Http addr port "" + mk l s = networkStorage l d s diff --git a/Storage.hs b/Storage.hs index 10e6bfe..de6eab3 100644 --- a/Storage.hs +++ b/Storage.hs @@ -13,14 +13,12 @@ import Types.Server import Types.Cost import Output import Share -import Storage.Local import Storage.Network import Servers import Tunables import Data.Maybe import Data.List import Data.Monoid -import System.FilePath import Control.Monad import Crypto.Random import System.Random @@ -28,15 +26,11 @@ import Control.Concurrent.Thread.Delay import Control.Concurrent.Async import qualified Data.Set as S import Network.Wai.Handler.Warp (Port) +import System.Random.Shuffle networkStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations -networkStorageLocations d = StorageLocations . map (networkStorage d) - <$> shuffleServers networkServers - -localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations -localStorageLocations d = StorageLocations $ - map (localStorage (storageDir d) . ("local" ) . show) - [1..100 :: Int] +networkStorageLocations = shuffleStorageLocations + . StorageLocations . serverList type UpdateProgress = IO () @@ -67,12 +61,11 @@ problemStoringIn (StorageLocations locs) tunables , "If you continue, some of the following less secure" , "servers will be used:" , "" - ] ++ map descserver alternates + ] ++ map descserver (mapMaybe getServer alternates) | otherwise = Nothing where ps = shareParams tunables - getlevel sl = filter (\s -> serverLevel s == sl) $ - mapMaybe getServer locs + getlevel sl = filter (\s -> storageLevel s == sl) locs alternates = getlevel Alternate descserver (Server { serverName = ServerName n, serverDesc = d}) = "* " ++ n ++ " -- " ++ d @@ -188,8 +181,8 @@ storeChaff hn port delayseconds = forever $ do mapConcurrently (go sis rng') [1..totalObjects (shareParams testModeTunables)] where - server = networkStorage Nothing $ - Server (ServerName hn) Untrusted [ServerAddress hn port] "chaff server" + server = networkStorage Untrusted Nothing $ + Server (ServerName hn) [ServerAddress hn port] "chaff server" objsize = objectSize defaultTunables * shareOverhead defaultTunables maxmsdelay = ceiling $ 1000000 * fromMaybe 0 delayseconds go sis rng n = do @@ -205,3 +198,11 @@ storeChaff hn port delayseconds = forever $ do StoreSuccess -> progress "+" _ -> progress "!" go sis' rng' n + +-- | Shuffles the list, keeping Recommended first, then +-- Alternate, and finally Untrusted. +shuffleStorageLocations :: StorageLocations -> IO StorageLocations +shuffleStorageLocations (StorageLocations l) = + StorageLocations . concat <$> mapM shuf [minBound..maxBound] + where + shuf sl = shuffleM (filter (\s -> storageLevel s == sl) l) diff --git a/Storage/Local.hs b/Storage/Local.hs index e061831..6dcaaae 100644 --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -35,13 +35,14 @@ type GetShareDir = Section -> IO FilePath newtype Section = Section String -localStorage :: GetShareDir -> String -> Storage -localStorage getsharedir n = Storage +localStorage :: StorageLevel -> GetShareDir -> String -> Storage +localStorage storagelevel getsharedir n = Storage { storeShare = store section getsharedir , retrieveShare = retrieve section getsharedir , obscureShares = obscure section getsharedir , countShares = count section getsharedir , moveShares = move section getsharedir + , storageLevel = storagelevel , uploadQueue = Nothing , getServer = Nothing } diff --git a/Storage/Network.hs b/Storage/Network.hs index f8169c9..e2004cc 100644 --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -17,15 +17,16 @@ import HTTP.Client import HTTP.ProofOfWork import System.FilePath -networkStorage :: Maybe LocalStorageDirectory -> Server -> Storage -networkStorage localdir server = Storage +networkStorage :: StorageLevel -> Maybe LocalStorageDirectory -> Server -> Storage +networkStorage storagelevel localdir server = Storage { storeShare = store server , retrieveShare = retrieve server , obscureShares = obscure server , countShares = count server , moveShares = move server - , uploadQueue = Just $ localStorage (storageDir localdir) + , uploadQueue = Just $ localStorage storagelevel (storageDir localdir) ("uploadqueue" name) + , storageLevel = storagelevel , getServer = Just server } where diff --git a/Tests.hs b/Tests.hs index 7955c7f..7294cfb 100644 --- a/Tests.hs +++ b/Tests.hs @@ -75,7 +75,7 @@ withTestStorageLocations a = bracket setup cleanup go setup = mkdtemp "keysafe-test" cleanup = removeDirectoryRecursive go tmpdir = a $ StorageLocations $ - map (localStorage (testStorageDir tmpdir) . show) + map (localStorage LocallyPreferred (testStorageDir tmpdir) . show) [1..100 :: Int] -- | Test of backup and restore of a SecretKey. diff --git a/Types/Server.hs b/Types/Server.hs index 5caf9db..9a2017d 100644 --- a/Types/Server.hs +++ b/Types/Server.hs @@ -27,12 +27,8 @@ newtype ServerName = ServerName { fromServerName :: String } instance ToJSON ServerName instance FromJSON ServerName -data ServerLevel = Recommended | Alternate | Untrusted - 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 diff --git a/Types/Storage.hs b/Types/Storage.hs index d9db853..c83593a 100644 --- a/Types/Storage.hs +++ b/Types/Storage.hs @@ -20,6 +20,9 @@ newtype StorageLocations = StorageLocations [Storage] newtype LocalStorageDirectory = LocalStorageDirectory FilePath +data StorageLevel = LocallyPreferred | Recommended | Alternate | Untrusted + deriving (Show, Eq, Ord, Bounded, Enum) + -- | Storage interface. This can be used both for local storage, -- an upload queue, or a remote server. -- @@ -35,6 +38,7 @@ data Storage = Storage , moveShares :: Storage -> IO [StoreResult] -- ^ Tries to move all shares from this storage to another one. , uploadQueue :: Maybe Storage + , storageLevel :: StorageLevel , getServer :: Maybe Server } diff --git a/keysafe.hs b/keysafe.hs index bd63ff1..11f52dc 100644 --- a/keysafe.hs +++ b/keysafe.hs @@ -20,7 +20,6 @@ import Cost import SecretKey import Share import Storage -import Servers import Types.Server import BackupLog import AutoStart @@ -86,7 +85,7 @@ dispatch cmdline ui tunables possibletunables = do go (CmdLine.Chaff hn) _ = storeChaff hn (CmdLine.serverPort (CmdLine.serverConfig cmdline)) (CmdLine.chaffMaxDelay cmdline) - go CmdLine.CheckServers _ = checkServers + go CmdLine.CheckServers _ = checkServers cmdline go CmdLine.Benchmark _ = benchmarkTunables tunables go CmdLine.Test _ = @@ -361,11 +360,7 @@ userName = do return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u) cmdLineStorageLocations :: CmdLine.CmdLine -> IO StorageLocations -cmdLineStorageLocations cmdline - | CmdLine.localstorage cmdline = return (localStorageLocations lsd) - | otherwise = networkStorageLocations lsd - where - lsd = CmdLine.localstoragedirectory cmdline +cmdLineStorageLocations = networkStorageLocations . CmdLine.localstoragedirectory getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword) getPasswordEntropy password name = do @@ -409,15 +404,17 @@ autoStart cmdline tunables ui = do else storeBackupLog =<< mkBackupLog (BackupSkipped (GpgKey kid)) -checkServers :: IO () -checkServers = do - say $ "Checking " ++ show (length networkServers) ++ " servers concurrently; please wait..." - results <- mapConcurrently check networkServers +checkServers :: CmdLine.CmdLine -> IO () +checkServers cmdline = do + StorageLocations sls <- cmdLineStorageLocations cmdline + let serverlist = mapMaybe getServer sls + say $ "Checking " ++ show (length serverlist) ++ " servers concurrently; please wait..." + results <- mapConcurrently check serverlist mapM_ displayresult results case filter failed results of [] -> return () l - | length l == length networkServers -> + | length l == length serverlist -> error "Failed to connect to any servers. Perhaps TOR is not running?" | otherwise -> error $ "Failed to connect to some servers: " -- cgit v1.2.3