diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -8,6 +8,7 @@ module Benchmark where import Types +import Output import Tunables import ExpensiveHash import HTTP.ProofOfWork @@ -86,33 +87,33 @@ benchmarkTunables :: Tunables -> IO () benchmarkTunables tunables = do - putStrLn "/proc/cpuinfo:" - putStrLn =<< readFile "/proc/cpuinfo" + say "/proc/cpuinfo:" + say =<< readFile "/proc/cpuinfo" - putStrLn "Benchmarking 1000 rounds of proof of work hash..." - print =<< benchmarkExpensiveHash 1000 (proofOfWorkHashTunable 0) + say "Benchmarking 1000 rounds of proof of work hash..." + display =<< benchmarkExpensiveHash 1000 (proofOfWorkHashTunable 0) - putStrLn "Benchmarking 60 rounds of 1 second proofs of work..." - print =<< benchmarkPoW 60 (Seconds 1) + say "Benchmarking 60 rounds of 1 second proofs of work..." + display =<< benchmarkPoW 60 (Seconds 1) - putStrLn "Benchmarking 10 rounds of 8 second proofs of work..." - print =<< benchmarkPoW 10 (Seconds 8) + say "Benchmarking 10 rounds of 8 second proofs of work..." + display =<< benchmarkPoW 10 (Seconds 8) -- Rather than run all 256 rounds of this hash, which would -- probably take on the order of 1 hour, run only 16, and scale -- the expected cost accordingly. let normalrounds = 256 * randomSaltBytes (keyEncryptionKeyTunable tunables) - putStrLn $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..." + say $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..." r <- benchmarkExpensiveHash' 16 (keyEncryptionKeyHash $ keyEncryptionKeyTunable tunables) (mapCost (/ (fromIntegral normalrounds / 16)) $ randomSaltBytesBruteForceCost $ keyEncryptionKeyTunable tunables) - print r - putStrLn $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..." - print $ BenchmarkResult + display r + say $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..." + display $ BenchmarkResult { expectedBenchmark = mapCost (* 16) (expectedBenchmark r) , actualBenchmark = mapCost (* 16) (actualBenchmark r) } - putStrLn "Benchmarking 1 round of name generation hash..." - print =<< benchmarkExpensiveHash 1 + say "Benchmarking 1 round of name generation hash..." + display =<< benchmarkExpensiveHash 1 (nameGenerationHash $ nameGenerationTunable tunables) diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,26 @@ +keysafe (0.20160927) unstable; urgency=medium + + * Makefile: Avoid rebuilding on make install, so that sudo make install works. + * 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. + * Don't upload more than neededshares-1 shares to Alternate servers + without asking the user if they want to do this potentially dangerous + action. + * Added a second keysafe server to the server list. It's provided + by Marek Isalski at Faelix. Currently located in UK, but planned move + to CH. Currently at Alternate level until verification is complete. + * Server: --motd can be used to provide a Message Of The Day. + * Added --check-servers mode, which is useful both at the command line + to see what servers keysafe knows about, and as a cron job. + * Server: Round number of objects down to the nearest thousand, to avoid + leaking too much data about when objects are uploaded to servers. + * Filter out escape sequences and any other unusual characters when + writing all messages to the console. + + -- Joey Hess Tue, 27 Sep 2016 20:25:35 -0400 + keysafe (0.20160922) unstable; urgency=medium * Keysafe now knows about 3 servers, although only 1 is currently in diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -8,6 +8,7 @@ import Types import Types.Storage import Types.Server (HostName) +import Types.Cost (Seconds(..)) import Tunables import qualified Gpg import Options.Applicative @@ -27,15 +28,17 @@ , name :: Maybe Name , othername :: Maybe Name , serverConfig :: ServerConfig + , chaffMaxDelay :: Maybe Seconds } -data Mode = Backup | Restore | UploadQueued | AutoStart | Server | BackupServer FilePath | RestoreServer FilePath | Chaff HostName | Benchmark | Test +data Mode = Backup | Restore | UploadQueued | AutoStart | Server | BackupServer FilePath | RestoreServer FilePath | Chaff HostName | CheckServers | Benchmark | Test deriving (Show) data ServerConfig = ServerConfig { serverPort :: Port , serverAddress :: String , monthsToFillHalfDisk :: Integer + , serverMotd :: Maybe T.Text } parse :: Parser CmdLine @@ -43,13 +46,14 @@ <$> optional parseMode <*> optional (gpgswitch <|> fileswitch) <*> localstorageswitch - <*> localstoragedirectoryopt + <*> optional localstoragedirectoryopt <*> guiswitch <*> testmodeswitch - <*> optional (ShareParams <$> totalobjects <*> neededobjects) - <*> nameopt - <*> othernameopt + <*> optional parseShareParams + <*> optional nameopt + <*> optional othernameopt <*> parseServerConfig + <*> optional chaffmaxdelayopt where gpgswitch = GpgKey . KeyId . T.pack <$> strOption ( long "gpgkeyid" @@ -65,7 +69,7 @@ ( long "store-local" <> help "Store data locally. (The default is to store data in the cloud.)" ) - localstoragedirectoryopt = optional $ LocalStorageDirectory <$> option str + localstoragedirectoryopt = LocalStorageDirectory <$> option str ( long "store-directory" <> metavar "DIR" <> help "Where to store data locally. (default: ~/.keysafe/objects/)" @@ -78,26 +82,21 @@ ( long "gui" <> help "Use GUI interface for interaction. Default is to use readline interface when run in a terminal, and GUI otherwise." ) - totalobjects = option auto - ( long "totalshares" - <> metavar "M" - <> help ("Configure the number of shares to split encrypted secret key into. (default: " ++ show (totalObjects (shareParams defaultTunables)) ++ ") (When this option is used to back up a key, it must also be provided at restore time.)") - ) - neededobjects = option auto - ( long "neededshares" - <> metavar "N" - <> help ("Configure the number of shares needed to restore. (default: " ++ show (neededObjects (shareParams defaultTunables)) ++ ") (When this option is used to back up a key, it must also be provided at restore time.)") - ) - nameopt = optional $ Name . BU8.fromString <$> strOption + nameopt = option nameOption ( long "name" <> metavar "N" <> help "Specify name used for key backup/restore, avoiding the usual prompt." ) - othernameopt = optional $ Name . BU8.fromString <$> strOption + othernameopt = option nameOption ( long "othername" <> metavar "N" <> help "Specify other name used for key backup/restore, avoiding the usual prompt." ) + chaffmaxdelayopt = option secondsOption + ( long "chaff-max-delay" + <> metavar "SECONDS" + <> help "Specify a delay between chaff uploads. Will delay a random amount between 0 and this many seconds." + ) parseMode :: Parser Mode parseMode = @@ -136,6 +135,10 @@ <> metavar "HOSTNAME" <> help "Upload random data to a keysafe server." ) + <|> flag' CheckServers + ( long "check-servers" + <> help "Tries to connect to each server in the server list. Displays the server's MOTD, and the amount of data stored on it. Prints message to stderr and exits nonzero if any of the servers are not accessible." + ) <|> flag' Benchmark ( long "benchmark" <> help "Benchmark speed of keysafe's cryptographic primitives." @@ -145,6 +148,25 @@ <> help "Run test suite." ) +parseShareParams :: Parser ShareParams +parseShareParams = ShareParams <$> totalobjects <*> neededobjects + where + totalobjects = option auto + ( long "totalshares" + <> metavar "M" + <> help ("Configure the number of shares to split encrypted secret key into. " + ++ showdefault totalObjects ++ neededboth) + ) + neededobjects = option auto + ( long "neededshares" + <> metavar "N" + <> help ("Configure the number of shares needed to restore. " + ++ showdefault neededObjects ++ neededboth) + ) + showdefault f = "(default: " ++ show (f (shareParams defaultTunables)) ++ ")" + neededboth = " (When this option is used to back up a key, it must also be provided at restore time.)" + + parseServerConfig :: Parser ServerConfig parseServerConfig = ServerConfig <$> option auto @@ -168,6 +190,11 @@ <> showDefault <> help "Server rate-limits requests and requires proof of work, to avoid too many objects being stored. This is an lower bound on how long it could possibly take for half of the current disk space to be filled." ) + <*> optional (T.pack <$> strOption + ( long "motd" + <> metavar "MESSAGE" + <> help "The server's Message Of The Day." + )) get :: IO CmdLine get = execParser opts @@ -193,3 +220,9 @@ customizeShareParams cmdline t = case customShareParams cmdline of Nothing -> t Just ps -> t { shareParams = ps } + +secondsOption :: ReadM Seconds +secondsOption = Seconds . toRational <$> (auto :: ReadM Double) + +nameOption :: ReadM Name +nameOption = Name . BU8.fromString <$> auto diff --git a/Crypto/Argon2.hs b/Crypto/Argon2.hs --- a/Crypto/Argon2.hs +++ b/Crypto/Argon2.hs @@ -152,9 +152,9 @@ -- will be throw. data Argon2Exception = -- | The length of the supplied password is outside the range supported by @libargon2@. - Argon2PasswordLengthOutOfRange !Word64 -- ^ The erroneous length. + Argon2PasswordLengthOutOfRange !CSize -- ^ The erroneous length. | -- | The length of the supplied salt is outside the range supported by @libargon2@. - Argon2SaltLengthOutOfRange !Word64 -- ^ The erroneous length. + Argon2SaltLengthOutOfRange !CSize -- ^ The erroneous length. | -- | Either too much or too little memory was requested via 'hashMemory'. Argon2MemoryUseOutOfRange !Word32 -- ^ The erroneous 'hashMemory' value. | -- | Either too few or too many iterations were requested via 'hashIterations'. @@ -167,7 +167,7 @@ instance Exception Argon2Exception -type Argon2Encoded = Word32 -> Word32 -> Word32 -> CString -> Word64 -> CString -> Word64 -> Word64 -> CString -> Word64 -> IO Int32 +type Argon2Encoded = Word32 -> Word32 -> Word32 -> CString -> CSize -> CString -> CSize -> CSize -> CString -> CSize -> IO Int32 hashEncoded' :: HashOptions -> BS.ByteString @@ -202,7 +202,7 @@ fmap T.decodeUtf8 (BS.packCString out) where argon2 = variant argon2i argon2d hashVariant -type Argon2Unencoded = Word32 -> Word32 -> Word32 -> CString -> Word64 -> CString -> Word64 -> CString -> Word64 -> IO Int32 +type Argon2Unencoded = Word32 -> Word32 -> Word32 -> CString -> CSize -> CString -> CSize -> CString -> CSize -> IO Int32 hash' :: HashOptions -> BS.ByteString diff --git a/Crypto/Argon2/FFI.hsc b/Crypto/Argon2/FFI.hsc --- a/Crypto/Argon2/FFI.hsc +++ b/Crypto/Argon2/FFI.hsc @@ -44,17 +44,17 @@ import Foreign import Foreign.C -foreign import ccall unsafe "argon2.h argon2i_hash_encoded" argon2i_hash_encoded :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> (#type const size_t) -> Ptr b -> (# type const size_t) -> (#type const size_t) -> CString -> (#type const size_t) -> IO (#type int) +foreign import ccall unsafe "argon2.h argon2i_hash_encoded" argon2i_hash_encoded :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> CSize -> Ptr b -> CSize -> CSize -> CString -> CSize -> IO (#type int) -foreign import ccall unsafe "argon2.h argon2i_hash_raw" argon2i_hash_raw :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> (#type const size_t) -> Ptr b -> (#type size_t) -> Ptr c -> (#type const size_t) -> IO (#type int) +foreign import ccall unsafe "argon2.h argon2i_hash_raw" argon2i_hash_raw :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> CSize -> Ptr b -> CSize -> Ptr c -> CSize -> IO (#type int) -foreign import ccall unsafe "argon2.h argon2d_hash_encoded" argon2d_hash_encoded :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> (#type const size_t) -> Ptr b -> (# type const size_t) -> (#type const size_t) -> CString -> (#type const size_t) -> IO (#type int) +foreign import ccall unsafe "argon2.h argon2d_hash_encoded" argon2d_hash_encoded :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> CSize -> Ptr b -> CSize -> CSize -> CString -> CSize -> IO (#type int) -foreign import ccall unsafe "argon2.h argon2d_hash_raw" argon2d_hash_raw :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> (#type const size_t) -> Ptr b -> (#type size_t) -> Ptr c -> (#type const size_t) -> IO (#type int) +foreign import ccall unsafe "argon2.h argon2d_hash_raw" argon2d_hash_raw :: (#type const uint32_t) -> (#type const uint32_t) -> (#type const uint32_t) -> Ptr a -> CSize -> Ptr b -> CSize -> Ptr c -> CSize -> IO (#type int) -foreign import ccall unsafe "argon2.h argon2i_verify" argon2i_verify :: CString -> Ptr a -> (#type const size_t) -> IO (#type int) +foreign import ccall unsafe "argon2.h argon2i_verify" argon2i_verify :: CString -> Ptr a -> CSize -> IO (#type int) -foreign import ccall unsafe "argon2.h argon2d_verify" argon2d_verify :: CString -> Ptr a -> (#type const size_t) -> IO (#type int) +foreign import ccall unsafe "argon2.h argon2d_verify" argon2d_verify :: CString -> Ptr a -> CSize -> IO (#type int) pattern ARGON2_OK = (#const ARGON2_OK) pattern ARGON2_OUTPUT_PTR_NULL = (#const ARGON2_OUTPUT_PTR_NULL) diff --git a/HTTP/Client.hs b/HTTP/Client.hs --- a/HTTP/Client.hs +++ b/HTTP/Client.hs @@ -76,7 +76,7 @@ serverRequest' srv a = go Nothing (serverUrls srv) where go lasterr [] = return $ Left $ - maybe "no available servers" (\err -> "server failure: " ++ show err) lasterr + maybe "no known address" (\err -> "server failure: " ++ show err) lasterr go _ (url:urls) = do manager <- torableManager res <- runExceptT $ a manager url diff --git a/HTTP/Server.hs b/HTTP/Server.hs --- a/HTTP/Server.hs +++ b/HTTP/Server.hs @@ -24,6 +24,7 @@ import Control.Concurrent import Control.Concurrent.Thread.Delay import Control.Concurrent.STM +import Data.Maybe import Data.String import qualified Data.ByteString as B @@ -32,6 +33,7 @@ , storage :: Storage , rateLimiter :: RateLimiter , logger :: Logger + , serverConfig :: ServerConfig } newServerState :: Maybe LocalStorageDirectory -> ServerConfig -> IO ServerState @@ -42,6 +44,7 @@ <*> pure (serverStorage d) <*> newRateLimiter cfg d l <*> pure l + <*> pure cfg runServer :: Maybe LocalStorageDirectory -> ServerConfig -> IO () runServer d cfg = do @@ -62,13 +65,13 @@ userAPI = Proxy server :: ServerState -> Server HttpAPI -server st = motd +server st = motd st :<|> getObject st :<|> putObject st :<|> countObjects st -motd :: Handler Motd -motd = return $ Motd "Hello World!" +motd :: ServerState -> Handler Motd +motd = return . Motd . fromMaybe "Hello World!" . serverMotd . serverConfig getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (POWGuarded StorableObject) getObject st i pow = rateLimit (rateLimiter st) (logger st) pow i $ do @@ -93,8 +96,13 @@ sz = B.length (fromStorableObject o) countObjects :: ServerState -> Maybe ProofOfWork -> Handler (POWGuarded CountResult) -countObjects st pow = rateLimit (rateLimiter st) (logger st) pow NoPOWIdent $ - liftIO $ countShares $ storage st +countObjects st pow = rateLimit (rateLimiter st) (logger st) pow NoPOWIdent $ do + v <- liftIO $ countShares $ storage st + case v of + CountResult n -> return $ + -- Round down to avoid leaking too much detail. + CountResult ((n `div` 1000) * 1000) + CountFailure s -> return (CountFailure s) -- | 1 is a dummy value; the server does not know the actual share numbers. dummyShareNum :: ShareNum diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -3,11 +3,18 @@ This installs keysafe to ~/.local/bin, and is sufficient to use keysafe to back up or restore your private key. -First install Haskell's stack tool, the zlib, g++, readline and argon2 -libraries, and zenity. For example, on a Debian system: +First install Haskell's stack tool, ghc, the zlib, g++, readline and argon2 +libraries. Also, zenity is needed to use keysafe's GUI. +For example, on a Debian testing system: - sudo apt-get install haskell-stack \ + sudo apt-get install haskell-stack ghc \ zlib1g-dev g++ libreadline-dev libargon2-0-dev zenity + +If your distribution does not yet include Haskell's stack tool, +see + +If your distribution does not yet include argon2, see + Then to build and install keysafe, run this in the keysafe directory: diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -2,7 +2,9 @@ # Can be stack or cabal BUILDER?=stack -build: keysafe +build: + rm -f keysafe + $(MAKE) keysafe keysafe: $(BUILDER) build @@ -32,5 +34,3 @@ install -m 0644 keysafe.desktop $(PREFIX)/usr/share/applications/keysafe.desktop install -d $(PREFIX)/etc/xdg/autostart/ install -m 0644 keysafe.autostart $(PREFIX)/etc/xdg/autostart/keysafe.desktop - -.PHONY: keysafe diff --git a/Output.hs b/Output.hs new file mode 100644 --- /dev/null +++ b/Output.hs @@ -0,0 +1,33 @@ +-- All console output in keysafe should go via this module; +-- avoid using putStrLn, print, etc directly. + +module Output (ask, progress, say, warn, display) where + +import System.IO +import Data.Char + +ask :: String -> IO () +ask s = do + putStr (escape s) + hFlush stdout + +progress :: String -> IO () +progress = ask + +say :: String -> IO () +say = putStrLn . escape + +warn :: String -> IO () +warn = hPutStrLn stderr . escape + +display :: Show s => s -> IO () +display = say . show + +-- | Prevent malicious escape sequences etc in a string +-- from being output to the console. +escape :: String -> String +escape = concatMap go + where + go c = if isPrint c || isSpace c + then [c] + else "\\" ++ show (ord c) diff --git a/Servers.hs b/Servers.hs --- a/Servers.hs +++ b/Servers.hs @@ -7,21 +7,39 @@ import Types.Server import Servant.Client - -serverUrls :: Server -> [BaseUrl] -serverUrls srv = map go (serverAddress srv) - where - go (ServerAddress addr port) = BaseUrl Http addr port "" +import System.Random.Shuffle +-- | Keysafe's server list. +-- +-- Note: Avoid removing servers from this list, as that will break +-- restores. If necessary, a server can be set to Untrusted to prevent +-- uploads to it. +-- +-- 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") + [ Server (ServerName "keysafe.joeyh.name") Alternate [ServerAddress "vzgrspuxbtnlrtup.onion" 4242] - -- Purism server is not yet deployed, but planned. - , Server (ServerName "keysafe.puri.sm") - [] - -- Unknown yet who will provide this server, but allocate it now - -- so keysafe can start queuing uploads to it. - , Server (ServerName "thirdserver") + "Provided by Joey Hess. Digital Ocean VPS, located in Indonesia" + + , Server (ServerName "keysafe.puri.sm") Alternate [] + "Purism server is not yet deployed, but planned." + + , 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) + +serverUrls :: Server -> [BaseUrl] +serverUrls srv = map go (serverAddress srv) + where + go (ServerAddress addr port) = BaseUrl Http addr port "" diff --git a/Storage.hs b/Storage.hs --- a/Storage.hs +++ b/Storage.hs @@ -10,6 +10,8 @@ import Types import Types.Storage import Types.Server +import Types.Cost +import Output import Share import Storage.Local import Storage.Network @@ -18,17 +20,18 @@ import Data.Maybe import Data.List import Data.Monoid -import System.IO import System.FilePath import Control.Monad import Crypto.Random +import System.Random +import Control.Concurrent.Thread.Delay 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 $ @@ -37,11 +40,48 @@ type UpdateProgress = IO () +data StorageProblem + = FatalProblem String + | OverridableProblem String + deriving (Show) + +-- | Check if there is a problem with storing shares amoung the provided +-- storage locations, assuming that some random set of the storage +-- locations will be used. +-- +-- It's always a problem to store anything on an Untrusted server. +-- +-- It should not be possible to reconstruct the encrypted +-- secret key using only objects from Alternate servers, so +-- fewer than neededObjects Alternate servers can be used. +problemStoringIn :: StorageLocations -> Tunables -> Maybe StorageProblem +problemStoringIn (StorageLocations locs) tunables + | not (null (getlevel Untrusted)) || length locs < totalObjects ps = + Just $ FatalProblem + "Not enough servers are available to store your encrypted secret key." + | length alternates >= neededObjects ps = Just $ OverridableProblem $ unlines $ + [ "Not enough keysafe servers are available that can store" + , "your encrypted secret key with a recommended level of" + , "security." + , "" + , "If you continue, some of the following less secure" + , "servers will be used:" + , "" + ] ++ map descserver alternates + | otherwise = Nothing + where + ps = shareParams tunables + getlevel sl = filter (\s -> serverLevel s == sl) $ + mapMaybe getServer locs + alternates = getlevel Alternate + descserver (Server { serverName = ServerName n, serverDesc = d}) = + "* " ++ n ++ " -- " ++ d + -- | Stores the shares amoung the storage locations. Each location -- gets at most one share from each set. -- -- If a server is not currently accessible, it will be queued locally. --- If this happens at all, returns True. +-- If any uploads are queued, returns True. -- -- TODO: Add shuffling and queueing/chaffing to prevent -- correlation of related shares. @@ -122,22 +162,22 @@ -- | 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) processresults (StoreAlreadyExists:rs) c = processresults rs ("Unable to upload a share to a server due to a name conflict.":c) -storeChaff :: HostName -> Port -> IO () -storeChaff hn port = forever $ do - putStrLn $ "Sending chaff to " ++ hn ++ " (press ctrl-c to stop)" - putStrLn "Legend: + = successful upload, ! = upload failure" +storeChaff :: HostName -> Port -> Maybe Seconds -> IO () +storeChaff hn port delayseconds = forever $ do + say $ "Sending chaff to " ++ hn ++ " (press ctrl-c to stop)" + say "Legend: + = successful upload, ! = upload failure" rng <- (cprgCreate <$> createEntropyPool) :: IO SystemRNG let (randomname, rng') = cprgGenerate 128 rng -- It's ok the use the testModeTunables here because @@ -148,17 +188,20 @@ mapConcurrently (go sis rng') [1..totalObjects (shareParams testModeTunables)] where - server = networkStorage Nothing $ Server (ServerName hn) - [ServerAddress hn port] + server = networkStorage Nothing $ + 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 + msdelay <- getStdRandom (randomR (0, maxmsdelay)) + delay msdelay + let (b, rng') = cprgGenerate objsize rng let share = Share 0 (StorableObject b) let (is, sis') = nextShareIdents sis let i = S.toList is !! (n - 1) r <- storeShare server i share case r of - StoreSuccess -> putStr "+" - _ -> putStr "!" - hFlush stdout + StoreSuccess -> progress "+" + _ -> progress "!" go sis' rng' n diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,10 +1,13 @@ Soon: * Get some keysafe servers set up. +* Set up --check-servers in a cron job, so I know when servers are down. Later: -* Implement the different categories of servers in the server list. +* 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. * 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. @@ -21,7 +24,8 @@ for up to several days, with some uploads of chaff, to prevent collaborating evil servers from correlating related shards. * Add some random padding to http requests and responses, to make it - harder for traffic analysis to tell that it's keysafe traffic. + harder for traffic analysis to tell that given TOR traffic is + keysafe traffic. Wishlist: diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -8,6 +8,7 @@ module Tests where import Types +import Output import Tunables import Encryption import Share @@ -16,7 +17,6 @@ import Control.Exception import System.Directory import System.Posix.Temp -import System.IO import qualified Data.ByteString.UTF8 as BU8 import qualified Data.ByteString as B import qualified Data.Set as S @@ -36,27 +36,27 @@ runTest :: Test -> IO Bool runTest (d, t) = do - putStr $ "testing: " ++ show d ++ " ..." - hFlush stdout + progress $ "testing: " ++ show d ++ " ..." r <- t case r of Right () -> do - putStrLn "ok" + say "ok" return True Left e -> do - putStrLn $ "failed: " ++ show e + say $ "failed: " ++ show e return False runTests :: IO () runTests = do r <- mapM runTest tests if all (== True) r - then putStrLn "All tests succeeded." + then say "All tests succeeded." else error "Tests failed. Report a bug!" tests :: [Test] tests = - [ backupRestoreTest "very small" $ + [ stableNamingTest "stable naming" + , backupRestoreTest "very small" $ testSecretKey 1 , backupRestoreTest "full size" $ testSecretKey (objectSize testModeTunables) @@ -64,7 +64,6 @@ testSecretKey (objectSize testModeTunables + 1) , backupRestoreTest "many chunks" $ testSecretKey (objectSize testModeTunables * 10) - , stableNamingTest "stable naming" ] testSecretKey :: Int -> SecretKey diff --git a/Types/Cost.hs b/Types/Cost.hs --- a/Types/Cost.hs +++ b/Types/Cost.hs @@ -14,7 +14,7 @@ deriving (Show, Eq, Ord) newtype Seconds = Seconds Rational - deriving (Num, Fractional, Eq, Ord) + deriving (Num, Fractional, Real, RealFrac, Eq, Ord) instance Show Seconds where show (Seconds n) = show (fromRational n :: Double) ++ "s" diff --git a/Types/Server.hs b/Types/Server.hs --- a/Types/Server.hs +++ b/Types/Server.hs @@ -21,15 +21,20 @@ -- | Name used in queuing uploads to the server. Should remain stable -- across keysafe versions. -newtype ServerName = ServerName String +newtype ServerName = ServerName { fromServerName :: String } deriving (Show, Eq, Ord, Generic) 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 } deriving (Show, Eq, Ord) diff --git a/UI/NonInteractive.hs b/UI/NonInteractive.hs --- a/UI/NonInteractive.hs +++ b/UI/NonInteractive.hs @@ -6,7 +6,7 @@ module UI.NonInteractive (noninteractiveUI) where import Types.UI -import System.IO +import Output import Control.Exception noninteractiveUI :: UI @@ -22,21 +22,19 @@ } myShowError :: Desc -> IO () -myShowError desc = hPutStrLn stderr $ "Error: " ++ desc +myShowError desc = warn $ "Error: " ++ desc myShowInfo :: Title -> Desc -> IO () -myShowInfo _title desc = putStrLn desc +myShowInfo _title desc = say desc myPrompt :: Title -> Desc -> x -> IO a myPrompt _title desc _ = do - putStrLn desc + say desc error "Not running at a terminal and zenity is not installed; cannot interact with user." myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a myWithProgress _title desc a = bracket_ setup cleanup (a sendpercent) where - setup = putStrLn desc - sendpercent p = do - putStr (show p ++ "% ") - hFlush stdout - cleanup = putStrLn "done" + setup = say desc + sendpercent p = progress (show p ++ "% ") + cleanup = say "done" diff --git a/UI/Readline.hs b/UI/Readline.hs --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -7,11 +7,11 @@ import Types.UI import Types +import Output import System.Console.Readline import System.Posix.Terminal import System.Posix.IO import Control.Exception -import System.IO import Data.List import Data.Char import Text.Read @@ -33,23 +33,23 @@ myShowError :: Desc -> IO () myShowError desc = do - hPutStrLn stderr $ "Error: " ++ desc + warn $ "Error: " ++ desc _ <- readline "[Press Enter]" - putStrLn "" + say "" myShowInfo :: Title -> Desc -> IO () myShowInfo title desc = do showTitle title - putStrLn desc - putStrLn "" + say desc + say "" myPromptQuestion :: Title -> Desc -> Question -> IO Bool myPromptQuestion title desc question = bracket_ setup cleanup go where setup = do showTitle title - putStrLn desc - cleanup = putStrLn "" + say desc + cleanup = say "" go = do mresp <- readline $ question ++ " [y/n] " case mresp of @@ -59,7 +59,7 @@ | "n" `isPrefixOf` (map toLower s) -> return False _ -> do - putStrLn "Please enter 'y' or 'n'" + say "Please enter 'y' or 'n'" go myPromptName :: Title -> Desc -> Maybe Name -> (Name -> Maybe Problem) -> IO (Maybe Name) @@ -68,8 +68,8 @@ where setup = do showTitle title - putStrLn desc - cleanup = putStrLn "" + say desc + cleanup = say "" go = do case suggested of Nothing -> return () @@ -81,10 +81,10 @@ let n = Name $ BU8.fromString s case checkproblem n of Nothing -> do - putStrLn "" + say "" return $ Just n Just problem -> do - putStrLn problem + say problem go Nothing -> return Nothing @@ -93,33 +93,31 @@ where setup = do showTitle title - putStrLn desc + say desc origattr <- getTerminalAttributes stdInput let newattr = origattr `withoutMode` EnableEcho setTerminalAttributes stdInput newattr Immediately return origattr cleanup origattr = do setTerminalAttributes stdInput origattr Immediately - putStrLn "" + say "" prompt = do - putStr "Enter password> " - hFlush stdout + ask "Enter password> " p1 <- getLine - putStrLn "" + say "" if confirm then promptconfirm p1 else return $ mkpassword p1 promptconfirm p1 = do - putStr "Confirm password> " - hFlush stdout + ask "Confirm password> " p2 <- getLine - putStrLn "" + say "" if p1 /= p2 then do - putStrLn "Passwords didn't match, try again..." + say "Passwords didn't match, try again..." prompt else do - putStrLn "" + say "" return $ mkpassword p1 mkpassword = Just . Password . BU8.fromString @@ -127,25 +125,24 @@ myPromptKeyId _ _ [] = return Nothing myPromptKeyId title desc l = do showTitle title - putStrLn desc - putStrLn "" + say desc + say "" forM_ nl $ \(n, ((Name name), (KeyId kid))) -> - putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")" + say $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")" prompt where nl = zip [1 :: Integer ..] l prompt = do - putStr "Enter number> " - hFlush stdout + ask "Enter number> " r <- getLine - putStrLn "" + say "" case readMaybe r of Just n | n > 0 && n <= length l -> do - putStrLn "" + say "" return $ Just $ snd (l !! pred n) _ -> do - putStrLn $ "Enter a number from 1 to " ++ show (length l) + say $ "Enter a number from 1 to " ++ show (length l) prompt myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a @@ -153,16 +150,14 @@ where setup = do showTitle title - putStrLn desc - sendpercent p = do - putStr (show p ++ "% ") - hFlush stdout + say desc + sendpercent p = ask (show p ++ "% ") cleanup = do - putStrLn "done" - putStrLn "" + say "done" + say "" showTitle :: Title -> IO () showTitle title = do - putStrLn title - putStrLn (replicate (length title) '-') - putStrLn "" + say title + say (replicate (length title) '-') + say "" diff --git a/keysafe.cabal b/keysafe.cabal --- a/keysafe.cabal +++ b/keysafe.cabal @@ -1,5 +1,5 @@ Name: keysafe -Version: 0.20160922 +Version: 0.20160927 Cabal-Version: >= 1.8 Maintainer: Joey Hess Author: Joey Hess @@ -72,6 +72,8 @@ , 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.* @@ -95,6 +97,7 @@ HTTP.ProofOfWork HTTP.Server HTTP.RateLimit + Output SecretKey Serialization ServerBackup diff --git a/keysafe.hs b/keysafe.hs --- a/keysafe.hs +++ b/keysafe.hs @@ -11,6 +11,7 @@ import Tunables import qualified CmdLine import UI +import Output import Encryption import Entropy import Benchmark @@ -19,10 +20,14 @@ import SecretKey import Share import Storage +import Servers import Types.Server import BackupLog import AutoStart +import HTTP import HTTP.Server +import HTTP.Client +import HTTP.ProofOfWork import ServerBackup import qualified Gpg import Data.Maybe @@ -31,6 +36,7 @@ import Data.Monoid import Data.List import Control.DeepSeq +import Control.Concurrent.Async import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU8 @@ -79,6 +85,8 @@ restoreServer (CmdLine.localstoragedirectory cmdline) d go (CmdLine.Chaff hn) _ = storeChaff hn (CmdLine.serverPort (CmdLine.serverConfig cmdline)) + (CmdLine.chaffMaxDelay cmdline) + go CmdLine.CheckServers _ = checkServers go CmdLine.Benchmark _ = benchmarkTunables tunables go CmdLine.Test _ = @@ -87,15 +95,31 @@ backup :: CmdLine.CmdLine -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO () backup cmdline ui tunables secretkeysource secretkey = do installAutoStartFile + + let m = totalObjects (shareParams tunables) + StorageLocations allocs <- cmdLineStorageLocations cmdline + let locs = StorageLocations (take m allocs) + case problemStoringIn locs tunables of + Nothing -> return () + Just (FatalProblem p) -> do + showError ui p + error "aborting" + Just (OverridableProblem p) -> do + ok <- promptQuestion ui "Server problem" + p "Continue anyway?" + if ok + then return () + else error "aborting" + username <- userName Name theirname <- case CmdLine.name cmdline of Just n -> pure n Nothing -> fromMaybe (error "Aborting on no username") <$> promptName ui "Enter your name" usernamedesc (Just username) validateName - go theirname + go theirname locs where - go theirname = do + go theirname locs = do cores <- fromMaybe 1 <$> getNumCores Name othername <- case CmdLine.name cmdline of Just n -> pure n @@ -106,15 +130,15 @@ (kek, passwordentropy) <- promptpassword name let sis = shareIdents tunables name secretkeysource let cost = getCreationCost kek <> getCreationCost sis - (r, queued, locs) <- withProgressIncremental ui "Encrypting and storing data" + (r, queued, usedlocs) <- withProgressIncremental ui "Encrypting and storing data" (encryptdesc cost cores) $ \addpercent -> do let esk = encrypt tunables kek secretkey shares <- genShares esk tunables _ <- esk `deepseq` addpercent 25 _ <- sis `seq` addpercent 25 let step = 50 `div` sum (map S.size shares) - storeShares (cmdLineStorageLocations cmdline) sis shares (addpercent step) - backuplog <- mkBackupLog $ backupMade (mapMaybe getServer locs) secretkeysource passwordentropy + storeShares locs sis shares (addpercent step) + backuplog <- mkBackupLog $ backupMade (mapMaybe getServer usedlocs) secretkeysource passwordentropy case r of StoreSuccess -> do storeBackupLog backuplog @@ -130,7 +154,7 @@ [ "Another secret key is already being stored under the name you entered." , "Please try again with a different name." ] - go theirname + go theirname locs promptpassword name = do password <- fromMaybe (error "Aborting on no password") <$> promptPassword ui True "Enter password" passworddesc @@ -223,7 +247,8 @@ <$> 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 @@ -235,12 +260,11 @@ 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 @@ -256,13 +280,13 @@ 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." @@ -336,9 +360,9 @@ 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 @@ -384,3 +408,41 @@ =<< Gpg.getSecretKey kid else storeBackupLog =<< mkBackupLog (BackupSkipped (GpgKey kid)) + +checkServers :: IO () +checkServers = do + say $ "Checking " ++ show (length networkServers) ++ " servers concurrently; please wait..." + results <- mapConcurrently check networkServers + mapM_ displayresult results + case filter failed results of + [] -> return () + l + | length l == length networkServers -> + error "Failed to connect to any servers. Perhaps TOR is not running?" + | otherwise -> + error $ "Failed to connect to some servers: " + ++ show (map (sn . fst) l) + where + check s = do + m <- serverRequest' s motd + c <- serverRequest s Left Right NoPOWIdent countObjects + case (m, c) of + (Right (Motd mt), Right (CountResult cr)) -> + return (s, Right (mt, cr)) + (Left e, _) -> return (s, Left e) + (_, Left e) -> return (s, Left e) + (_, Right (CountFailure e)) -> return (s, Left e) + + displayresult (s, v) = do + say $ "* " ++ sn s ++ " -- " ++ serverDesc s + case v of + Right (mt, cr) -> do + say $ " MOTD: " ++ T.unpack mt + say $ " object count: " ++ show cr + Left e -> warn $ + " failed to connect to " ++ sn s ++ ": " ++ e + + failed (_, Left _) = True + failed _ = False + + sn = fromServerName . serverName