diff options
Diffstat (limited to 'keysafe.hs')
| -rw-r--r-- | keysafe.hs | 459 |
1 files changed, 459 insertions, 0 deletions
diff --git a/keysafe.hs b/keysafe.hs new file mode 100644 index 0000000..996c0a7 --- /dev/null +++ b/keysafe.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns #-} + +{- Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Main where + +import Types +import Tunables +import qualified CmdLine +import UI +import Output +import Encryption +import Entropy +import Benchmark +import Tests +import Cost +import SecretKey +import Share +import Storage +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 +import Data.Time.Clock +import Data.Time.Calendar +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 +import qualified Data.Set as S +import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID) + +main :: IO () +main = do + cmdline <- CmdLine.get + ui <- selectUI (CmdLine.gui cmdline) + let mkt = CmdLine.customizeShareParams cmdline + (tunables, possibletunables) <- if CmdLine.testMode cmdline + then do + showInfo ui "Test mode" + "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 + +dispatch :: CmdLine.CmdLine -> UI -> Tunables -> [Tunables] -> IO () +dispatch cmdline ui tunables possibletunables = do + mode <- CmdLine.selectMode cmdline + go mode (CmdLine.secretkeysource cmdline) + where + go CmdLine.Backup (Just secretkeysource) = + backup cmdline ui tunables (Distinguisher secretkeysource) + =<< getSecretKey secretkeysource + go CmdLine.Restore (Just secretkeydest) = + restore cmdline ui possibletunables (Distinguisher secretkeydest) + go CmdLine.Backup Nothing = + backup cmdline ui tunables AnyGpgKey + =<< Gpg.getKeyToBackup ui + go CmdLine.Restore Nothing = + restore cmdline ui possibletunables AnyGpgKey + go CmdLine.UploadQueued _ = + uploadQueued ui (CmdLine.localstoragedirectory cmdline) + go CmdLine.AutoStart _ = + autoStart cmdline tunables ui + go (CmdLine.Server) _ = + runServer + (CmdLine.localstoragedirectory cmdline) + (CmdLine.serverConfig cmdline) + go (CmdLine.BackupServer d) _ = + backupServer (CmdLine.localstoragedirectory cmdline) d + go (CmdLine.RestoreServer d) _ = + restoreServer (CmdLine.localstoragedirectory cmdline) d + go (CmdLine.Chaff hn) _ = storeChaff hn + (CmdLine.serverPort (CmdLine.serverConfig cmdline)) + (CmdLine.chaffMaxDelay cmdline) + go CmdLine.CheckServers _ = checkServers cmdline + go CmdLine.Benchmark _ = + benchmarkTunables tunables + go CmdLine.Test _ = + runTests + +backup :: CmdLine.CmdLine -> UI -> Tunables -> Distinguisher -> (SecretKeySource, SecretKey) -> IO () +backup cmdline ui tunables distinguisher (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 locs + where + go theirname locs = do + cores <- fromMaybe 1 <$> getNumCores + Name othername <- case CmdLine.name cmdline of + Just n -> pure n + Nothing -> fromMaybe (error "aborting on no othername") + <$> promptName ui "Enter other name" + othernamedesc Nothing validateName + let name = Name (theirname <> " " <> othername) + (kek, passwordentropy) <- promptpassword name + let sis = shareIdents tunables name distinguisher + let cost = getCreationCost kek <> getCreationCost sis + (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 locs sis shares (addpercent step) + backuplog <- mkBackupLog $ backupMade (mapMaybe getServer usedlocs) secretkeysource passwordentropy + case r of + StoreSuccess -> do + storeBackupLog backuplog + if queued + then do + willautostart <- isAutoStartFileInstalled + showInfo ui "Backup queued" $ "Some data was not successfully uploaded to servers, and has been queued for later upload." + ++ if willautostart then "" else " Run keysafe --uploadqueued at a later point to finish the backup." + else showInfo ui "Backup success" "Your secret key was successfully encrypted and backed up." + StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s) + StoreAlreadyExists -> do + showError ui $ unlines + [ "Another secret key is already being stored under the name you entered." + , "Please try again with a different name." + ] + go theirname locs + promptpassword name = do + password <- fromMaybe (error "Aborting on no password") + <$> promptPassword ui True "Enter password" passworddesc + kek <- genKeyEncryptionKey tunables name password + passwordentropy <- getPasswordEntropy password name + let crackcost = estimateAttackCost spotAWS $ + estimateBruteforceOf kek passwordentropy + let mincost = Dollars 100000 + if crackcost < mincost + then do + showError ui $ "Weak password! It would cost only " ++ show crackcost ++ " to crack the password. Please think of a better one. More words would be good.." + promptpassword name + else do + (thisyear, _, _) <- toGregorian . utctDay + <$> getCurrentTime + ok <- promptQuestion ui "Password strength estimate" + (crackdesc crackcost thisyear) + "Is your password strong enough?" + if ok + then return (kek, passwordentropy) + else promptpassword name + keydesc = case secretkeysource of + GpgKey _ -> "gpg secret key" + KeyFile _ -> "secret key" + usernamedesc = unlines + [ "Keysafe is going to backup your " ++ keydesc ++ " securely." + , "" + , "You will be prompted for some information. To restore your " ++ keydesc + , "at a later date, you will need to remember and enter the same information." + , "" + , "To get started, what is your name?" + ] + othernamedesc = unlines + [ "Now think of another name, which not many people know." + , "This will be used to make it hard for anyone else to find" + , "the backup of your " ++ keydesc ++ "." + , "" + , "Some suggestions:" + , "" + , otherNameSuggestions + , "" + , "Make sure to pick a name you will remember later," + , "when you restore your " ++ keydesc ++ "." + ] + passworddesc = unlines + [ "Pick a password that will be used to protect your secret key." + , "" + , "It's very important that this password be hard to guess." + , "" + , "And, it needs to be one that you will be able to remember years from now" + , "in order to restore your secret key." + ] + crackdesc crackcost thisyear = unlines $ + "Rough estimate of the cost to crack your password: " : + costOverTimeTable crackcost thisyear + encryptdesc cost cores = unlines + [ "This will probably take around " ++ showCostMinutes cores cost + , "" + , "(It's a feature that this takes a while; it makes it hard" + , "for anyone to find your data, or crack your password.)" + , "" + , "Please wait..." + ] + +otherNameSuggestions :: String +otherNameSuggestions = unlines $ map (" * " ++) + [ "Your high-school sweetheart." + , "Your first pet." + , "Your favorite teacher." + , "Your college roomate." + , "A place you like to visit." + ] + +restore :: CmdLine.CmdLine -> UI -> [Tunables] -> Distinguisher -> IO () +restore cmdline ui possibletunables distinguisher = do + cores <- fromMaybe 1 <$> getNumCores + 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" + namedesc (Just username) validateName + Name othername <- case CmdLine.name cmdline of + Just n -> pure n + Nothing -> fromMaybe (error "aborting on no othername") + <$> promptName ui "Enter other name" + othernamedesc Nothing validateName + let name = Name (theirname <> " " <> othername) + password <- fromMaybe (error "Aborting on no password") + <$> promptPassword ui True "Enter password" passworddesc + + let mksis tunables = shareIdents tunables name distinguisher + 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 + let candidatekeys = candidateKeyEncryptionKeys tunables name password + let cost = getCreationCost candidatekeys + <> castCost (getDecryptionCost candidatekeys) + case combineShares tunables [shares] of + Left e -> showError ui e + Right esk -> do + final <- withProgress ui "Decrypting" + (decryptdesc cost cores) $ \setpercent -> + go locs tunables [shares] usedservers sis setpercent $ + tryDecrypt candidatekeys esk + final =<< getPasswordEntropy password name + where + 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 + _ <- setpercent 100 + oldgpgkeys <- if distinguisher == AnyGpgKey then Gpg.listSecretKeys else return [] + writeSecretKey distinguisher secretkey + newgpgkeys <- if distinguisher == AnyGpgKey then Gpg.listSecretKeys else return [] + return $ \passwordentropy -> do + showInfo ui "Success" "Your secret key was successfully restored!" + -- Since the key was restored, we know it's + -- backed up; log that. + let updatelog restored = do + backuplog <- mkBackupLog $ + backupMade firstusedservers restored passwordentropy + storeBackupLog backuplog + case distinguisher of + AnyGpgKey -> case filter (`notElem` oldgpgkeys) newgpgkeys of + [(_n, k)] -> updatelog (GpgKey k) + _ -> return () + Distinguisher sks -> updatelog sks + DecryptIncomplete kek -> do + -- Download shares for another chunk. + (nextshares, sis', nextusedservers) + <- 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 locs tunables shares usedservers sis' setpercent $ + decrypt kek esk + namedesc = unlines + [ "When you backed up your secret key, you entered some information." + , "To restore it, you'll need to remember what you entered back then." + , "" + , "To get started, what is your name?" + ] + othernamedesc = unlines + [ "What other name did you enter when you backed up your secret key?" + , "" + , "Back then, you were given some suggestions, like these:" + , "" + , otherNameSuggestions + ] + passworddesc = unlines + [ "Enter the password to unlock your secret key." + ] + decryptdesc cost cores = unlines + [ "This will probably take around " ++ showCostMinutes cores cost + , "" + , "(It's a feature that this takes so long; it prevents cracking your password.)" + , "" + , "Please wait..." + ] + +-- | Try each possible tunable until the initial set of +-- shares are found, and return the shares, and +-- ShareIdents to download subsequent sets. +downloadInitialShares + :: StorageLocations + -> UI + -> (Tunables -> ShareIdents) + -> [Tunables] + -> IO (Maybe (Tunables, S.Set Share, ShareIdents, [Server])) +downloadInitialShares storagelocations ui mksis possibletunables = do + cores <- fromMaybe 1 <$> getNumCores + withProgressIncremental ui "Downloading encrypted data" (message cores) $ \addpercent -> do + go possibletunables addpercent + where + go [] _ = return Nothing + go (tunables:othertunables) addpercent = do + -- Just calculating the hash to generate the stream of idents + -- probably takes most of the time. + let !sis = mksis tunables + addpercent 50 + let m = totalObjects (shareParams tunables) + let step = 50 `div` m + (shares, sis', usedservers) <- retrieveShares storagelocations sis (addpercent step) + if S.null shares + then go othertunables addpercent + else return $ Just (tunables, shares, sis', usedservers) + + possiblesis = map mksis possibletunables + message cores = unlines + [ "This will probably take around " + ++ showCostMinutes cores (mconcat $ map getCreationCost possiblesis) + , "" + , "(It's a feature that this takes a while; it makes it hard" + , "for anyone else to find your data.)" + , "" + , "Please wait..." + ] + +validateName :: Name -> Maybe Problem +validateName (Name n) + | B.length n < 2 = Just "The name should be at least 2 letters long." + | otherwise = Nothing + +userName :: IO Name +userName = do + u <- getUserEntryForID =<< getEffectiveUserID + return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u) + +cmdLineStorageLocations :: CmdLine.CmdLine -> IO StorageLocations +cmdLineStorageLocations cmdline = do + preflocs <- StorageLocations . catMaybes <$> + mapM (\mk -> mk lsd) (CmdLine.preferredStorage cmdline) + shuffleStorageLocations (preflocs <> netlocs) + where + netlocs = networkStorageLocations lsd + lsd = CmdLine.localstoragedirectory cmdline + +getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword) +getPasswordEntropy password name = do + username <- userName + let badwords = concatMap namewords [name, username] + return $ calcPasswordEntropy password badwords + where + namewords (Name nb) = words (BU8.toString nb) + +uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO () +uploadQueued ui d = do + problems <- tryUploadQueued d + if null problems + then return () + else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.") + +autoStart :: CmdLine.CmdLine -> Tunables -> UI -> IO () +autoStart cmdline tunables ui = do + -- Upload queued first, before making any more backups that might + -- queue more. + uploadQueued ui (CmdLine.localstoragedirectory cmdline) + + -- Ask about backing up any gpg secret key that has not been backed up + -- or asked about before. If there are multiple secret keys, only + -- the first one is asked about, to avoid flooding with prompts + -- if the user for some reason generated a lot of secret keys. + ls <- readBackupLogs + ks <- Gpg.listSecretKeys + case filter (\(_, k) -> not $ any (matchesSecretKeySource (GpgKey k)) ls) ks of + [] -> return () + ((Name n,kid@(KeyId kt)):_) -> do + let kdesc = if length ks < 2 + then "gpg secret key " + else "gpg secret key for " ++ BU8.toString n ++ " (" ++ T.unpack kt ++ ") " + ans <- promptQuestion ui ("Back up gpg secret key?") + ("Your " ++ kdesc ++ " has not been backed up by keysafe yet.\n\nKeysafe can securely back up the secret key to the cloud, protected with a password.\n") + "Do you want to back up the gpg secret key now?" + if ans + then backup cmdline ui tunables AnyGpgKey + =<< getSecretKey (GpgKey kid) + else storeBackupLog + =<< mkBackupLog (BackupSkipped (GpgKey kid)) + +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 serverlist -> + 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 |