diff options
| -rw-r--r-- | Shard.hs | 4 | ||||
| -rw-r--r-- | Types.hs | 3 | ||||
| -rw-r--r-- | Types/UI.hs | 1 | ||||
| -rw-r--r-- | UI/Readline.hs | 38 | ||||
| -rw-r--r-- | UI/Zenity.hs | 13 | ||||
| -rw-r--r-- | keysafe.hs | 55 |
6 files changed, 95 insertions, 19 deletions
@@ -19,6 +19,7 @@ import qualified Raaz.Hash.Sha256 as Raaz import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Monoid +import Control.DeepSeq data ShardIdents = ShardIdents { getIdents :: [StorableObjectIdent] @@ -26,6 +27,9 @@ data ShardIdents = ShardIdents , identsBruteForceCalc :: CostCalc BruteForceOp UnknownName } +instance NFData ShardIdents where + rnf = rnf . getIdents + instance HasCreationCost ShardIdents where getCreationCost = identsCreationCost @@ -18,6 +18,9 @@ newtype SecretKey = SecretKey B.ByteString -- | The secret key, encrypted with a password. data EncryptedSecretKey = EncryptedSecretKey B.ByteString (CostCalc BruteForceOp UnknownPassword) +instance NFData EncryptedSecretKey where + rnf (EncryptedSecretKey b _) = rnf b + instance Show EncryptedSecretKey where show (EncryptedSecretKey b _) = show b diff --git a/Types/UI.hs b/Types/UI.hs index 7508293..77a3095 100644 --- a/Types/UI.hs +++ b/Types/UI.hs @@ -12,6 +12,7 @@ import Types data UI = UI { isAvailable :: IO Bool , showError :: Desc -> IO () + , showInfo :: Title -> Desc -> IO () , promptQuestion :: Title -> Desc -> Question -> IO Bool , promptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) , promptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) diff --git a/UI/Readline.hs b/UI/Readline.hs index ed619df..c75bd19 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -22,6 +22,7 @@ readlineUI :: UI readlineUI = UI { isAvailable = queryTerminal stdInput , showError = myShowError + , showInfo = myShowInfo , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword @@ -32,14 +33,22 @@ readlineUI = UI myShowError :: Desc -> IO () myShowError desc = do hPutStrLn stderr $ "Error: " ++ desc + _ <- readline "[Press Enter]" putStrLn "" -myPromptQuestion :: Title -> Desc -> Question -> IO Bool -myPromptQuestion title desc question = do +myShowInfo :: Title -> Desc -> IO () +myShowInfo title desc = do showTitle title putStrLn desc - go + putStrLn "" + +myPromptQuestion :: Title -> Desc -> Question -> IO Bool +myPromptQuestion title desc question = bracket_ setup cleanup go where + setup = do + showTitle title + putStrLn desc + cleanup = putStrLn "" go = do mresp <- readline $ question ++ " [y/n] " case mresp of @@ -53,11 +62,13 @@ myPromptQuestion title desc question = do go myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) -myPromptName title desc (Name suggested) checkproblem = do - showTitle title - putStrLn desc - go +myPromptName title desc (Name suggested) checkproblem = + bracket_ setup cleanup go where + setup = do + showTitle title + putStrLn desc + cleanup = putStrLn "" go = do addHistory (BU8.toString suggested) mname <- readline "Name> " @@ -75,7 +86,7 @@ myPromptName title desc (Name suggested) checkproblem = do Nothing -> return Nothing myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) -myPromptPassword confirm title desc = bracket setup teardown (const prompt) +myPromptPassword confirm title desc = bracket setup cleanup (const prompt) where setup = do showTitle title @@ -84,7 +95,9 @@ myPromptPassword confirm title desc = bracket setup teardown (const prompt) let newattr = origattr `withoutMode` EnableEcho setTerminalAttributes stdInput newattr Immediately return origattr - teardown origattr = setTerminalAttributes stdInput origattr Immediately + cleanup origattr = do + setTerminalAttributes stdInput origattr Immediately + putStrLn "" prompt = do putStr "Enter password> " hFlush stdout @@ -125,14 +138,15 @@ myPromptKeyId title desc l = do putStrLn "" case readMaybe r of Just n - | n > 0 && n < length l -> + | n > 0 && n < length l -> do + putStrLn "" return $ Just $ snd (l !! n) _ -> do putStrLn $ "Enter a number from 1 to " ++ show (length l) prompt myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a -myWithProgress title desc a = bracket_ setup teardown (a sendpercent) +myWithProgress title desc a = bracket_ setup cleanup (a sendpercent) where setup = do showTitle title @@ -140,7 +154,7 @@ myWithProgress title desc a = bracket_ setup teardown (a sendpercent) sendpercent p = do putStr (show p ++ "% ") hFlush stdout - teardown = do + cleanup = do putStrLn "done" putStrLn "" diff --git a/UI/Zenity.hs b/UI/Zenity.hs index 228b11a..a419b62 100644 --- a/UI/Zenity.hs +++ b/UI/Zenity.hs @@ -23,6 +23,7 @@ zenityUI = UI loc <- filterM (\p -> doesFileExist (p </> "zenity")) ps return (not (null loc)) , showError = myShowError + , showInfo = myShowInfo , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword @@ -42,6 +43,18 @@ myShowError desc = bracket go cleanup (\_ -> return ()) _ <- waitZenity h return () +myShowInfo :: Title -> Desc -> IO () +myShowInfo title desc = bracket go cleanup (\_ -> return ()) + where + go = runZenity + [ "--info" + , "--title", title + , "--text", desc + ] + cleanup h = do + _ <- waitZenity h + return () + myPromptQuestion :: Title -> Desc -> Question -> IO Bool myPromptQuestion title desc question = do h <- runZenity @@ -35,9 +35,12 @@ main :: IO () main = do cmdline <- CmdLine.get ui <- selectUI (CmdLine.gui cmdline) - let tunables = if CmdLine.testMode cmdline - then testModeTunables - else defaultTunables + tunables <- 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 testModeTunables + else return defaultTunables mode <- CmdLine.selectMode cmdline go mode (CmdLine.secretkeysource cmdline) tunables ui where @@ -89,11 +92,26 @@ backup ui tunables secretkeysource secretkey = do <$> promptName ui "Enter name" namedesc username validateName kek <- promptkek name - let esk = encrypt tunables kek secretkey let sis = shardIdents tunables name secretkeysource - shards <- genShards esk tunables - print =<< mapM (uncurry (storeShard localFiles)) (zip (getIdents sis) shards) - print =<< obscureShards localFiles + let cost = getCreationCost kek <> getCreationCost sis + r <- withProgress ui "Encrypting and storing data" + (encryptdesc cost) $ \setpercent -> do + let esk = encrypt tunables kek secretkey + shards <- genShards esk tunables + _ <- esk `deepseq` setpercent 25 + _ <- sis `deepseq` setpercent 50 + let step = 50 `div` length shards + let percentsteps = map setpercent [50+step, 50+step*2..100] + storeShards sis (zip percentsteps shards) + 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) + StoreAlreadyExists -> do + showError ui $ unlines + [ "Another secret key is already being stored under the name you entered." + , "Please try again with a different name." + ] + backup ui tunables secretkeysource secretkey where promptkek name = do password <- fromMaybe (error "Aborting on no password") @@ -139,6 +157,14 @@ backup ui tunables secretkeysource secretkey = do crackdesc crackcost thisyear = unlines $ "Rough estimate of the cost to crack your password: " : costOverTimeTable crackcost thisyear + encryptdesc cost = unlines + [ "This will probably take around " ++ showCostMinutes 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..." + ] restore :: UI -> SecretKeySource -> IO () restore ui secretkeydest = do @@ -164,6 +190,7 @@ restore ui secretkeydest = do setpercent 100 -- TODO save print secretkey + showInfo ui "Success" "Your secret key successfully restored!" where -- TODO: derive by probing to find objects tunables = testModeTunables -- defaultTunables @@ -185,6 +212,20 @@ restore ui secretkeydest = do , "Please wait..." ] +storeShards :: ShardIdents -> [(IO (), Shard)] -> IO StoreResult +storeShards sis shards = do + r <- go (zip (getIdents sis) shards) + _ <- obscureShards localFiles + return r + where + go [] = return StoreSuccess + go ((i,(showprogress, s)):rest) = do + r <- storeShard localFiles i s + _ <- showprogress + case r of + StoreSuccess -> go rest + _ -> return r + downloadShards :: UI -> ShardIdents -> IO [Maybe Shard] downloadShards ui sis = bracket_ (return ()) cleanup (withProgress ui "Downloading encrypted data" message go) |