diff options
| -rw-r--r-- | Encryption.hs | 129 | ||||
| -rw-r--r-- | Share.hs | 57 | ||||
| -rw-r--r-- | Storage.hs | 54 | ||||
| -rw-r--r-- | TODO | 1 | ||||
| -rw-r--r-- | Tunables.hs | 3 | ||||
| -rw-r--r-- | Types.hs | 13 | ||||
| -rw-r--r-- | keysafe.hs | 101 |
7 files changed, 235 insertions, 123 deletions
diff --git a/Encryption.hs b/Encryption.hs index 4a8f5cf..fbeb1c6 100644 --- a/Encryption.hs +++ b/Encryption.hs @@ -21,6 +21,7 @@ import qualified Raaz.Cipher.Internal as Raaz import qualified Data.Text.Encoding as E import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.UTF8 as BU8 import Text.Read type AesKey = Raaz.KEY256 @@ -29,27 +30,43 @@ cipher :: Raaz.AES 256 'Raaz.CBC cipher = Raaz.aes256cbc encrypt :: Tunables -> KeyEncryptionKey -> SecretKey -> EncryptedSecretKey -encrypt tunables kek (SecretKey secret) = EncryptedSecretKey b (keyBruteForceCalc kek) +encrypt tunables kek (SecretKey secret) = + EncryptedSecretKey (chunk (objectSize tunables) b) (keyBruteForceCalc kek) where -- Raaz does not seem to provide a high-level interface -- for AES encryption, so use unsafeEncrypt. The use of -- EncryptableBytes makes sure it's provided with a -- multiple of the AES block size. b = Raaz.unsafeEncrypt cipher (keyEncryptionKey kek, keyEncryptionIV kek) $ - getEncryptableBytes $ toEncryptableBytes tunables secret + getEncryptableBytes $ encodeEncryptableBytes tunables secret -decrypt :: Candidates KeyEncryptionKey -> EncryptedSecretKey -> Maybe SecretKey -decrypt (Candidates l _ _) esk = go l +data DecryptResult + = DecryptSuccess SecretKey + | DecryptIncomplete KeyEncryptionKey + | DecryptFailed + +-- | Tries each candidate key in turn until one unlocks the encrypted data. +-- +-- When the EncryptedSecretKey is truncated, returns IncompleteDecrypt. +-- This avoids needing to try the candidate keys again after retrieving +-- more chunks. +tryDecrypt :: Candidates KeyEncryptionKey -> EncryptedSecretKey -> DecryptResult +tryDecrypt (Candidates l _ _) esk = go l where - go [] = Nothing - go (kek:rest) = case decrypt' kek esk of - Just sk -> Just sk - Nothing -> go rest + go [] = DecryptFailed + go (kek:rest) = case decrypt kek esk of + DecryptFailed -> go rest + r -> r -decrypt' :: KeyEncryptionKey -> EncryptedSecretKey -> Maybe SecretKey -decrypt' kek (EncryptedSecretKey b _) = SecretKey <$> fromEncryptableBytes pbs +decrypt :: KeyEncryptionKey -> EncryptedSecretKey -> DecryptResult +decrypt kek (EncryptedSecretKey cs _) = case decodeEncryptableBytes pbs of + Nothing -> DecryptFailed + Just (DecodeSuccess secretkey) -> DecryptSuccess (SecretKey secretkey) + Just DecodeIncomplete -> DecryptIncomplete kek where - pbs = EncryptableBytes $ Raaz.unsafeDecrypt cipher (keyEncryptionKey kek, keyEncryptionIV kek) b + pbs = EncryptableBytes $ + Raaz.unsafeDecrypt cipher (keyEncryptionKey kek, keyEncryptionIV kek) b + b = B.concat cs -- | An AES key, which is used to encrypt the secret key that is stored -- in keysafe. @@ -128,6 +145,15 @@ allByteStringsOfLength = go [] w <- [0..255] go (w:ws) (n-1) +chunk :: Int -> B.ByteString -> [B.ByteString] +chunk n = go [] + where + go cs b + | B.length b <= n = b : reverse cs + | otherwise = + let (h, t) = B.splitAt n b + in go (h:cs) t + -- Use the sha256 of the name (truncated) as the IV. genIV :: Name -> Raaz.IV genIV (Name name) = @@ -164,23 +190,45 @@ hashToAESKey (ExpensiveHash _ t) = b = B.take (fromIntegral $ Raaz.byteSize (undefined :: AesKey)) $ Raaz.toByteString $ Raaz.sha256 (E.encodeUtf8 t) --- | A bytestring that can be AES encrypted. It includes a checksum, --- and size, and is padded to the objectSize with NULs. +-- | A bytestring that can be AES encrypted. +-- +-- It is padded to a multiple of the objectSize with NULs. +-- Since objectSize is a multiple of the AES blocksize, so is this. +-- +-- Format is: +-- +-- sizeNULsizeshaNULdatashaNULdata -- --- This is a multiple of the AES blocksize, as long as objectSize is, --- which should always be the case. +-- The size gives the length of the data. If the data is shorter +-- than that, we know that the bytestring is truncated. +-- +-- The datasha is the sha256 of the data. This is checked when decoding +-- to guard against corruption. +-- +-- The sizesha is the sha256 of the size. This is included as a sanity +-- check that the right key was used to decrypt it. It's not unlikely +-- that using the wrong key could result in a bytestring that starts +-- with wrongsizeNUL, but it's astronomically unlikely that the +-- sizesha matches in this case. newtype EncryptableBytes = EncryptableBytes { getEncryptableBytes :: B.ByteString } deriving (Show) -toEncryptableBytes :: Tunables -> B.ByteString -> EncryptableBytes -toEncryptableBytes tunables b = EncryptableBytes $ - padBytes (objectSize tunables) $ - checksum <> sep <> len <> sep <> b +encodeEncryptableBytes :: Tunables -> B.ByteString -> EncryptableBytes +encodeEncryptableBytes tunables content = EncryptableBytes $ + padBytes (objectSize tunables) $ B.intercalate sep + [ size + , sha size + , sha content + , content + ] where - checksum = Raaz.toByteString $ Raaz.sha256 b - len = B8.pack (show (B.length b)) + size = B8.pack (show (B.length content)) sep = B.singleton 0 +-- | Encoded, so that it does not contain any NULs. +sha :: B.ByteString -> B.ByteString +sha = BU8.fromString . Raaz.showBase16 . Raaz.sha256 + padBytes :: Int -> B.ByteString -> B.ByteString padBytes n b = b <> padding where @@ -190,17 +238,28 @@ padBytes n b = b <> padding | r == 0 = B.empty | otherwise = B.replicate (n - r) 0 -fromEncryptableBytes :: EncryptableBytes -> Maybe B.ByteString -fromEncryptableBytes (EncryptableBytes b) = case B.break (== 0) b of - (checksum, rest) - | B.null checksum || B.null rest -> Nothing - | otherwise -> do - case B.break (== 0) (B.drop 1 rest) of - (lenb, rest') - | B.null lenb || B.null rest' -> Nothing - | otherwise -> do - len <- readMaybe (B8.unpack lenb) - let d = B.take len $ B.drop 1 rest' - if checksum == Raaz.toByteString (Raaz.sha256 d) - then Just d - else Nothing +data DecodeResult + = DecodeSuccess B.ByteString + | DecodeIncomplete + deriving (Show) + +decodeEncryptableBytes :: EncryptableBytes -> Maybe DecodeResult +decodeEncryptableBytes (EncryptableBytes b) = do + (sizeb, rest) <- getword b + (sizesha, rest') <- getword rest + (contentsha, rest'') <- getword rest' + if sha sizeb /= sizesha + then Nothing + else do + size <- readMaybe (B8.unpack sizeb) + let content = B.take size rest'' + if B.length content /= size + then return DecodeIncomplete + else if sha content /= contentsha + then Nothing + else return (DecodeSuccess content) + where + getword d = case B.break (== 0) d of + (w, rest) + | B.null w || B.null rest-> Nothing + | otherwise -> Just (w, B.drop 1 rest) @@ -18,18 +18,21 @@ import qualified Raaz.Core.Encode as Raaz import qualified Raaz.Hash.Sha256 as Raaz import qualified Data.Text as T import qualified Data.Text.Encoding as E +import qualified Data.Set as S import Data.Monoid -import Control.DeepSeq data ShareIdents = ShareIdents - { getIdents :: [StorableObjectIdent] - -- ^ An infinite list of idents to use for shares. + { identsStream :: [S.Set StorableObjectIdent] + -- ^ Each item in the infinite list is the idents to + -- use for the shares of a chunk of data. , identsCreationCost :: Cost CreationOp , identsBruteForceCalc :: CostCalc BruteForceOp UnknownName } -instance NFData ShareIdents where - rnf = rnf . getIdents +nextShareIdents :: ShareIdents -> (S.Set StorableObjectIdent, ShareIdents) +nextShareIdents sis = + let (s:rest) = identsStream sis + in (s, sis { identsStream = rest }) instance HasCreationCost ShareIdents where getCreationCost = identsCreationCost @@ -45,7 +48,7 @@ instance Bruteforceable ShareIdents UnknownName where -- when the same name is chosen for multiple keys. shareIdents :: Tunables -> Name -> SecretKeySource -> ShareIdents shareIdents tunables (Name name) keyid = - ShareIdents idents creationcost bruteforcecalc + ShareIdents (segmentbyshare idents) creationcost bruteforcecalc where (ExpensiveHash creationcost basename) = expensiveHash hashtunables (Salt keyid) name @@ -53,31 +56,41 @@ shareIdents tunables (Name name) keyid = E.encodeUtf8 $ basename <> T.pack (show n) mksha :: B.ByteString -> Raaz.Base16 mksha = Raaz.encode . Raaz.sha256 - idents = map mk [1..] bruteforcecalc = bruteForceLinearSearch creationcost hashtunables = nameGenerationHash $ nameGenerationTunable tunables + idents = map mk ([1..] :: [Integer]) + m = totalObjects (shareParams tunables) + segmentbyshare l = + let (shareis, l') = splitAt m l + in S.fromList shareis : segmentbyshare l' -genShares :: EncryptedSecretKey -> Tunables -> IO [Share] -genShares (EncryptedSecretKey esk _) tunables = do - shares <- SS.encode - (neededObjects $ shareParams tunables) - (totalObjects $ shareParams tunables) - (BL.fromStrict esk) - return $ map (\(n, share) -> Share n (StorableObject $ encodeShare share)) - (zip [1..] shares) +-- | Generates shares of an EncryptedSecretKey. +-- Each chunk of the key creates its own set of shares. +genShares :: EncryptedSecretKey -> Tunables -> IO [S.Set Share] +genShares (EncryptedSecretKey cs _) tunables = do + shares <- mapM encode cs + return $ map (S.fromList . map (uncurry Share) . zip [1..]) shares + where + encode :: B.ByteString -> IO [StorableObject] + encode b = map (StorableObject . encodeShare) + <$> SS.encode + (neededObjects $ shareParams tunables) + (totalObjects $ shareParams tunables) + (BL.fromStrict b) -combineShares :: Tunables -> [Share] -> Either String EncryptedSecretKey +-- | If not enough sets of shares are provided, the EncryptedSecretKey may +-- be incomplete, only containing some chunks of the key +combineShares :: Tunables -> [S.Set Share] -> Either String EncryptedSecretKey combineShares tunables shares - | null shares = - Left "No shares could be downloaded. Perhaps you entered the wrong name or password?" - | length shares < neededObjects (shareParams tunables) = + | null shares || any null shares || any (\l -> length l < sharesneeded) shares = Left "Not enough shares are currently available to reconstruct your data." - | otherwise = Right $ mk $ SS.decode $ map decodeshare shares + | otherwise = Right $ mk $ + map (BL.toStrict . SS.decode . map decodeshare . S.toList) shares where - mk b = EncryptedSecretKey (BL.toStrict b) unknownCostCalc + mk cs = EncryptedSecretKey cs unknownCostCalc decodeshare (Share sharenum so) = decodeShare sharenum sharesneeded $ fromStorableObject so - sharesneeded = neededObjects $ shareParams tunables + sharesneeded = neededObjects (shareParams tunables) -- | This efficient encoding relies on the share using a finite field of -- size 256, so it maps directly to bytes. @@ -14,6 +14,7 @@ import Data.Monoid import Data.Maybe import System.FilePath import Control.Monad +import qualified Data.Set as S allStorageLocations :: IO StorageLocations allStorageLocations = do @@ -29,50 +30,67 @@ localStorageLocations = StorageLocations $ type UpdateProgress = IO () -- | Stores the shares amoung the storage locations. Each location --- gets at most one share. -storeShares :: StorageLocations -> ShareIdents -> [(UpdateProgress, Share)] -> IO StoreResult -storeShares (StorageLocations locs) sis shares = do - (r, usedlocs) <- go locs [] Nothing (zip (getIdents sis) shares) +-- gets at most one share from each set. +-- +-- TODO: Add shuffling and queueing/chaffing to prevent +-- correlation of related shares. +storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO StoreResult +storeShares (StorageLocations locs) allsis shares updateprogress = do + (r, usedlocs) <- go allsis shares [] _ <- mapM_ obscureShares usedlocs return r where - go _ usedlocs _ [] = return (StoreSuccess, usedlocs) - go [] usedlocs lasterr _ = + go sis (s:rest) usedlocs = do + let (is, sis') = nextShareIdents sis + (r, usedlocs') <- storeset locs [] Nothing (zip (S.toList is) (S.toList s)) + case r of + StoreSuccess -> go sis' rest (usedlocs ++ usedlocs') + _ -> return (r, usedlocs ++ usedlocs') + go _ [] usedlocs = return (StoreSuccess, usedlocs) + + storeset _ usedlocs _ [] = return (StoreSuccess, usedlocs) + storeset [] usedlocs lasterr _ = return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs) - go (loc:otherlocs) usedlocs _ tostore@((i,(showprogress, s)):rest) = do + storeset (loc:otherlocs) usedlocs _ ((i, s):rest) = do r <- storeShare loc i s case r of StoreSuccess -> do - _ <- showprogress - go otherlocs (loc:usedlocs) Nothing rest - StoreFailure _ -> go otherlocs usedlocs (Just r) tostore + _ <- updateprogress + storeset otherlocs (loc:usedlocs) Nothing rest -- Give up if any location complains a share -- already exists, because we have a name conflict. StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs) + -- Try storing it somewhere else on failure. + StoreFailure _ -> + storeset otherlocs usedlocs (Just r) ((i, s):rest) --- | Retrieves shares from among the storage locations, and returns all --- the shares it can find, which may not be all that were requested. +-- | Retrieves one set of shares from the storage locations. +-- Returns all the shares it can find, which may not be enough, +-- and the remaining Shareidents, to use to get subsequent sets. -- -- Assumes that each location only contains one share. So, once a -- share has been found on a location, can avoid asking that location -- for any other shares. -retrieveShares :: StorageLocations -> [(UpdateProgress, (ShareNum, StorableObjectIdent))] -> IO [Share] -retrieveShares (StorageLocations locs) l = do - (shares, usedlocs, _unusedlocs) <- go locs [] l [] +retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents) +retrieveShares (StorageLocations locs) sis updateprogress = do + let (is, sis') = nextShareIdents sis + let want = zip [1..] (S.toList is) + (shares, usedlocs, _unusedlocs) <- go locs [] want [] _ <- mapM_ obscureShares usedlocs - return shares + return (S.fromList shares, sis') where go unusedlocs usedlocs [] shares = return (shares, usedlocs, unusedlocs) go [] usedlocs _ shares = return (shares, usedlocs, []) - go (loc:otherlocs) usedlocs (toretrieve@(updateprogress, (n, i)):rest) shares = do + go (loc:otherlocs) usedlocs ((n, i):rest) shares = do r <- retrieveShare loc n i case r of RetrieveSuccess s -> do _ <- updateprogress go otherlocs (loc:usedlocs) rest (s:shares) RetrieveFailure _ -> do + -- Try to get the share from other locations. (shares', usedlocs', unusedlocs) <- - go otherlocs usedlocs [toretrieve] shares + go otherlocs usedlocs [(n, i)] shares -- May need to ask the location that didn't -- have the share for a later share, but -- ask it last. This way, the first @@ -1,4 +1,3 @@ -* splitting large secret keys * tune hashes on more powerful hardware than thermal throttling laptop * store to servers * Run --uploadqueued periodically (systemd timer?) diff --git a/Tunables.hs b/Tunables.hs index 77c3296..ce7aa6e 100644 --- a/Tunables.hs +++ b/Tunables.hs @@ -36,7 +36,8 @@ data Tunables = Tunables { shareParams :: ShareParams , objectSize :: Int -- ^ a StorableObject is exactly this many bytes in size - -- (must be a multiple of AES block size 16) + -- (must be a multiple of AES block size 16, and cannot be smaller + -- than 256 bytes) , nameGenerationTunable :: NameGenerationTunable , keyEncryptionKeyTunable :: KeyEncryptionKeyTunable , encryptionTunable :: EncryptionTunable @@ -15,28 +15,29 @@ import Control.DeepSeq -- | keysafe stores secret keys. newtype SecretKey = SecretKey B.ByteString --- | The secret key, encrypted with a password. -data EncryptedSecretKey = EncryptedSecretKey B.ByteString (CostCalc BruteForceOp UnknownPassword) +-- | The secret key, encrypted with a password, in fixed size chunks. +data EncryptedSecretKey = EncryptedSecretKey [B.ByteString] (CostCalc BruteForceOp UnknownPassword) instance NFData EncryptedSecretKey where - rnf (EncryptedSecretKey bs _) = rnf bs + rnf (EncryptedSecretKey cs _) = rnf cs instance Show EncryptedSecretKey where - show (EncryptedSecretKey bs _) = show bs + show (EncryptedSecretKey cs _) = show cs instance Bruteforceable EncryptedSecretKey UnknownPassword where getBruteCostCalc (EncryptedSecretKey _ cc) = cc -- | An object in a form suitable to be stored on a keysafe server. newtype StorableObject = StorableObject { fromStorableObject :: B.ByteString } - deriving (Show) + deriving (Show, Eq, Ord) -- | An identifier for a StorableObject newtype StorableObjectIdent = StorableObjectIdent B.ByteString - deriving (Show, NFData) + deriving (Show, Eq, Ord, NFData) -- | A Shamir secret share, with a known number (N of M). data Share = Share ShareNum StorableObject + deriving (Eq, Ord) type ShareNum = Int @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} {- Copyright 2016 Joey Hess <id@joeyh.name> - @@ -26,6 +26,7 @@ import Data.Monoid import Control.DeepSeq 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 () @@ -80,15 +81,14 @@ backup storagelocations ui tunables secretkeysource secretkey = do kek <- promptkek name let sis = shareIdents tunables name secretkeysource let cost = getCreationCost kek <> getCreationCost sis - r <- withProgress ui "Encrypting and storing data" - (encryptdesc cost) $ \setpercent -> do + r <- withProgressIncremental ui "Encrypting and storing data" + (encryptdesc cost) $ \addpercent -> do let esk = encrypt tunables kek secretkey shares <- genShares esk tunables - _ <- esk `deepseq` setpercent 25 - _ <- sis `deepseq` setpercent 50 - let step = 50 `div` length shares - let percentsteps = map setpercent [50+step, 50+step*2..100] - storeShares storagelocations sis (zip percentsteps shares) + _ <- esk `deepseq` addpercent 25 + _ <- sis `seq` addpercent 25 + let step = 50 `div` sum (map S.size shares) + storeShares storagelocations sis shares (addpercent step) case r of StoreSuccess -> showInfo ui "Success" "Your secret key successfully encrypted and backed up." StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s) @@ -188,22 +188,35 @@ restore storagelocations ui possibletunables secretkeydest = do <$> promptPassword ui True "Enter password" passworddesc let mksis tunables = shareIdents tunables name secretkeydest - (tunables, shares) <- downloadShares storagelocations ui mksis possibletunables - - 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 -> 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 -> do - setpercent 100 - writeSecretKey secretkeydest secretkey - showInfo ui "Success" "Your secret key successfully restored!" + r <- downloadInitialShares storagelocations ui mksis possibletunables + case r of + Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name or password?" + Just (tunables, shares, sis) -> 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 -> withProgress ui "Decrypting" + (decryptdesc cost) $ \setpercent -> + go tunables [shares] sis setpercent $ + tryDecrypt candidatekeys esk where + go tunables firstshares sis setpercent r = case r of + DecryptFailed -> showError ui "Decryption failed! Unknown why it would fail at this point." + DecryptSuccess secretkey -> do + _ <- setpercent 100 + writeSecretKey secretkeydest secretkey + showInfo ui "Success" "Your secret key successfully restored!" + DecryptIncomplete kek -> do + -- Download shares for another chunk. + (nextshares, sis') <- retrieveShares storagelocations sis (return ()) + let shares = firstshares ++ [nextshares] + case combineShares tunables shares of + Left e -> showError ui e + Right esk -> + go tunables shares 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." @@ -214,6 +227,7 @@ restore storagelocations ui possibletunables secretkeydest = do [ "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 @@ -228,24 +242,31 @@ restore storagelocations ui possibletunables secretkeydest = do , "Please wait..." ] -downloadShares :: StorageLocations -> UI -> (Tunables -> ShareIdents) -> [Tunables] -> IO (Tunables, [Share]) -downloadShares storagelocations ui mksis possibletunables = - withProgress ui "Downloading encrypted data" message $ - go possibletunables +-- | Try each possible tunable until the initial set of +-- shares are found, the return the shares, and +-- ShareIdents to download subsequent sets. +downloadInitialShares + :: StorageLocations + -> UI + -> (Tunables -> ShareIdents) + -> [Tunables] + -> IO (Maybe (Tunables, S.Set Share, ShareIdents)) +downloadInitialShares storagelocations ui mksis possibletunables = + withProgressIncremental ui "Downloading encrypted data" message $ \addpercent -> do + go possibletunables addpercent where - go [] _ = return (defaultTunables, []) - go (tunables:othertunables) setpercent = do - let sis = mksis tunables - 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 = map setpercent [50+step, 50+step*2..100] - shares <- retrieveShares storagelocations (zip percentsteps l) - if null shares - then go othertunables setpercent - else return (tunables, shares) + 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') <- retrieveShares storagelocations sis (addpercent step) + if S.null shares + then go othertunables addpercent + else return $ Just (tunables, shares, sis') possiblesis = map mksis possibletunables message = unlines |