diff options
| -rw-r--r-- | Encryption.hs | 34 | ||||
| -rw-r--r-- | ExpensiveHash.hs | 3 | ||||
| -rw-r--r-- | Shard.hs | 13 | ||||
| -rw-r--r-- | Types.hs | 3 | ||||
| -rw-r--r-- | Types/Cost.hs | 13 | ||||
| -rw-r--r-- | Types/UI.hs | 4 | ||||
| -rw-r--r-- | UI/Readline.hs | 6 | ||||
| -rw-r--r-- | UI/Zenity.hs | 2 | ||||
| -rw-r--r-- | keysafe.hs | 75 |
9 files changed, 125 insertions, 28 deletions
diff --git a/Encryption.hs b/Encryption.hs index 8d508d8..d5a9879 100644 --- a/Encryption.hs +++ b/Encryption.hs @@ -38,8 +38,16 @@ encrypt tunables kek (SecretKey secret) = EncryptedSecretKey b (keyBruteForceCal b = Raaz.unsafeEncrypt cipher (keyEncryptionKey kek, keyEncryptionIV kek) $ getEncryptableBytes $ toEncryptableBytes tunables secret -decrypt :: KeyEncryptionKey -> EncryptedSecretKey -> Maybe SecretKey -decrypt kek (EncryptedSecretKey b _) = SecretKey <$> fromEncryptableBytes pbs +decrypt :: Candidates KeyEncryptionKey -> EncryptedSecretKey -> Maybe SecretKey +decrypt (Candidates l _ _) esk = go l + where + go [] = Nothing + go (kek:rest) = case decrypt' kek esk of + Just sk -> Just sk + Nothing -> go rest + +decrypt' :: KeyEncryptionKey -> EncryptedSecretKey -> Maybe SecretKey +decrypt' kek (EncryptedSecretKey b _) = SecretKey <$> fromEncryptableBytes pbs where pbs = EncryptableBytes $ Raaz.unsafeDecrypt cipher (keyEncryptionKey kek, keyEncryptionIV kek) b @@ -48,13 +56,28 @@ decrypt kek (EncryptedSecretKey b _) = SecretKey <$> fromEncryptableBytes pbs data KeyEncryptionKey = KeyEncryptionKey { keyEncryptionKey :: AesKey , keyEncryptionIV :: Raaz.IV + , keyCreationCost :: Cost CreationOp , keyDecryptionCost :: Cost DecryptionOp , keyBruteForceCalc :: CostCalc BruteForceOp UnknownPassword } +instance HasCreationCost KeyEncryptionKey where + getCreationCost = keyCreationCost + +instance HasDecryptionCost KeyEncryptionKey where + getDecryptionCost = keyDecryptionCost + instance Bruteforceable KeyEncryptionKey UnknownPassword where getBruteCostCalc = keyBruteForceCalc +data Candidates a = Candidates [a] (Cost CreationOp) (Cost DecryptionOp) + +instance HasCreationCost (Candidates a) where + getCreationCost (Candidates _ c _) = c + +instance HasDecryptionCost (Candidates a) where + getDecryptionCost (Candidates _ _ c) = c + -- | The ExpensiveHash of the Password used as the KeyEncryptionKey -- -- Name is used as a salt, to prevent rainbow table attacks. @@ -81,16 +104,17 @@ genKeyEncryptionKeys saltprefixes tunables (Name name) (Password password) = decryptcost = castCost $ randomSaltBytesBruteForceCost kektunables kektunables = keyEncryptionKeyTunable tunables - mk saltprefix = KeyEncryptionKey (hashToAESKey hash) iv decryptcost bruteforcecalc + mk saltprefix = KeyEncryptionKey (hashToAESKey hash) iv (getCreationCost hash) decryptcost bruteforcecalc where salt = Salt (saltprefix <> name) hash = expensiveHash (keyEncryptionKeyHash kektunables) salt password -- | A stream of all the key encryption keys that need to be tried to -- decrypt. -candidateKeyEncryptionKeys :: Tunables -> Name -> Password -> [KeyEncryptionKey] +candidateKeyEncryptionKeys :: Tunables -> Name -> Password -> Candidates KeyEncryptionKey candidateKeyEncryptionKeys tunables name password = - genKeyEncryptionKeys saltprefixes tunables name password + let ks@(k:_) = genKeyEncryptionKeys saltprefixes tunables name password + in Candidates ks (getCreationCost k) (getDecryptionCost k) where saltprefixes = allByteStringsOfLength $ randomSaltBytes $ keyEncryptionKeyTunable tunables diff --git a/ExpensiveHash.hs b/ExpensiveHash.hs index 9cf647f..ed7e859 100644 --- a/ExpensiveHash.hs +++ b/ExpensiveHash.hs @@ -28,6 +28,9 @@ import Data.Monoid data ExpensiveHash = ExpensiveHash (Cost CreationOp) T.Text deriving (Show) +instance HasCreationCost ExpensiveHash where + getCreationCost (ExpensiveHash c _) = c + data Salt t = Salt t expensiveHash :: Encodable t => ExpensiveHashTunable -> Salt t -> B.ByteString -> ExpensiveHash @@ -26,6 +26,9 @@ data ShardIdents = ShardIdents , identsBruteForceCalc :: CostCalc BruteForceOp UnknownName } +instance HasCreationCost ShardIdents where + getCreationCost = identsCreationCost + instance Bruteforceable ShardIdents UnknownName where getBruteCostCalc = identsBruteForceCalc @@ -59,9 +62,13 @@ genShards (EncryptedSecretKey esk _) tunables = do return $ map (\(n, share) -> Shard n (StorableObject $ encodeShare share)) (zip [1..] shares) --- Throws AssertionFailed if the number of shares is too small. -combineShards :: Tunables -> [Shard] -> EncryptedSecretKey -combineShards tunables = mk . SS.decode . map decodeshard +combineShards :: Tunables -> [Shard] -> Either String EncryptedSecretKey +combineShards tunables shards + | null shards = + Left "No shards could be downloaded. Perhaps you entered the wrong name or password?" + | length shards < minimum (map neededObjects (shardParams tunables)) = + Left "Not enough are shards currently available to reconstruct your data." + | otherwise = Right $ mk $ SS.decode $ map decodeshard shards where mk b = EncryptedSecretKey (BL.toStrict b) unknownCostCalc decodeshard (Shard sharenum so) = decodeShare sharenum sharesneeded $ @@ -10,6 +10,7 @@ module Types where import Types.Cost import qualified Data.ByteString as B import Data.String +import Control.DeepSeq -- | keysafe stores secret keys. newtype SecretKey = SecretKey B.ByteString @@ -30,7 +31,7 @@ newtype StorableObject = StorableObject { fromStorableObject :: B.ByteString } -- | An identifier for a StorableObject newtype StorableObjectIdent = StorableObjectIdent B.ByteString - deriving (Show) + deriving (Show, NFData) -- | A shard, with a known number (N of M). data Shard = Shard ShardNum StorableObject diff --git a/Types/Cost.hs b/Types/Cost.hs index 2f181a2..2aa6ee7 100644 --- a/Types/Cost.hs +++ b/Types/Cost.hs @@ -34,11 +34,24 @@ instance Monoid (Cost t) where mapCost :: (Integer -> Integer) -> Cost op -> Cost op mapCost f (CPUCost (Seconds n)) = CPUCost (Seconds (f n)) +showCostMinutes :: Cost op -> String +showCostMinutes (CPUCost (Seconds n)) + | n < 61 = "1 minute" + | otherwise = show (n `div` 60) ++ " minutes" + -- | Operations whose cost can be measured. data DecryptionOp data CreationOp data BruteForceOp +-- | Things that track their creation cost. +class HasCreationCost t where + getCreationCost :: t -> Cost CreationOp + +-- | Things that track their decryption cost. +class HasDecryptionCost t where + getDecryptionCost :: t -> Cost DecryptionOp + -- | Calculation of a cost that depends on some amount of entropy. type CostCalc op t = Entropy t -> Cost op diff --git a/Types/UI.hs b/Types/UI.hs index 0a0c789..7508293 100644 --- a/Types/UI.hs +++ b/Types/UI.hs @@ -3,6 +3,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Types.UI where import Types @@ -14,7 +16,7 @@ data UI = UI , promptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) , promptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) , promptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) - , withProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () + , withProgress :: forall a. Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a } type Title = String diff --git a/UI/Readline.hs b/UI/Readline.hs index 23be2e3..ed619df 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -131,7 +131,7 @@ myPromptKeyId title desc l = do putStrLn $ "Enter a number from 1 to " ++ show (length l) prompt -myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () +myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a myWithProgress title desc a = bracket_ setup teardown (a sendpercent) where setup = do @@ -140,7 +140,9 @@ myWithProgress title desc a = bracket_ setup teardown (a sendpercent) sendpercent p = do putStr (show p ++ "% ") hFlush stdout - teardown = putStrLn "done" + teardown = do + putStrLn "done" + putStrLn "" showTitle :: Title -> IO () showTitle title = do diff --git a/UI/Zenity.hs b/UI/Zenity.hs index b74631f..228b11a 100644 --- a/UI/Zenity.hs +++ b/UI/Zenity.hs @@ -115,7 +115,7 @@ myPromptKeyId title desc l = do return $ Just (KeyId (BU8.fromString kid)) else return Nothing -myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () +myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a myWithProgress title desc a = bracket setup teardown (a . sendpercent) where setup = do @@ -22,7 +22,11 @@ import qualified Gpg 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) @@ -40,7 +44,7 @@ main = do go CmdLine.Backup (Just secretkeysource@(GpgKey kid)) tunables ui = do ok <- Gpg.knownByKeyServer kid unless ok $ - error "Your gpg public key has to be stored on the keyservers before you can back it up by keyid. Either use gpg --send-key to store the public key on the keyservers, or omit the --gpgkeyid option" + showError ui "Your gpg public key has to be stored on the keyservers before you can back it up by keyid. Either use gpg --send-key to store the public key on the keyservers, or omit the --gpgkeyid option" backup ui tunables secretkeysource =<< getSecretKey secretkeysource go CmdLine.Backup (Just secretkeysource) tunables ui = @@ -146,21 +150,21 @@ restore ui secretkeydest = do <$> promptPassword ui True "Enter password" passworddesc let sis = shardIdents tunables name secretkeydest - -- we drop 1 to simulate not getting all shards from the servers - let l = drop 1 $ zip [1..] (getIdents sis) - - shards <- map (\(RetrieveSuccess s) -> s) - <$> mapM (uncurry (retrieveShard localFiles)) l - _ <- obscureShards localFiles - - let esk = combineShards tunables shards - go esk (candidateKeyEncryptionKeys tunables name password) + shards <- catMaybes <$> downloadShards ui sis + let candidatekeys = candidateKeyEncryptionKeys tunables name password + let cost = getCreationCost candidatekeys + <> castCost (getDecryptionCost candidatekeys) + case combineShards tunables shards of + Left e -> showError ui e + Right esk -> withProgress ui "Decrypting" + (decryptdesc cost) $ \setpercent -> do + case decrypt candidatekeys esk of + Nothing -> showError ui "Decryption failed! Unknown why it would fail at this point." + Just (SecretKey secretkey) -> do + setpercent 100 + -- TODO save + print secretkey where - go _ [] = error "decryption failed" - go esk (kek:rest) = case decrypt kek esk of - Just (SecretKey sk) -> print sk - Nothing -> go esk rest - -- TODO: derive by probing to find objects tunables = testModeTunables -- defaultTunables namedesc = unlines @@ -172,6 +176,47 @@ restore ui secretkeydest = do passworddesc = unlines [ "Enter the password to unlock your secret key." ] + decryptdesc cost = unlines + [ "This will probably take around " ++ showCostMinutes cost + , "" + , "(It's a feature that this takes so long;" + , "it prevents cracking your password.)" + , "" + , "Please wait..." + ] + +downloadShards :: UI -> ShardIdents -> IO [Maybe Shard] +downloadShards ui sis = bracket_ (return ()) cleanup + (withProgress ui "Downloading encrypted data" message go) + where + go setpercent = do + let l = zip [1..] (getIdents sis) + -- Just calculating the idents probably takes + -- most of the time. + _ <- l `deepseq` setpercent 50 + let step = 50 `div` length l + let percentsteps = [50+step, 50+step*2..100] + + forM (zip percentsteps l) $ \(pct, (n, i)) -> do + r <- retrieveShard localFiles n i + _ <- setpercent pct + case r of + RetrieveSuccess s -> do + return (Just s) + RetrieveFailure f -> do + hPutStrLn stderr $ + "warning: retrieval of shard " ++ show n ++ " failed: " ++ f + return Nothing + cleanup = obscureShards localFiles + message = unlines + [ "This will probably take around " + ++ showCostMinutes (getCreationCost sis) + , "" + , "(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) |