diff options
| -rw-r--r-- | Gpg.hs | 26 | ||||
| -rw-r--r-- | Types/UI.hs | 3 | ||||
| -rw-r--r-- | UI/Readline.hs | 73 | ||||
| -rw-r--r-- | UI/Zenity.hs | 61 | ||||
| -rw-r--r-- | keysafe.cabal | 1 | ||||
| -rw-r--r-- | keysafe.hs | 42 |
6 files changed, 158 insertions, 48 deletions
@@ -7,14 +7,32 @@ module Gpg where import Types import System.Process +import Data.List.Split +import Data.Maybe +import System.Exit +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BU8 listSecretKeys :: IO [(Name, KeyId)] -listSecretKeys = undefined --- gpg --batch --with-colons --list-secret-keys --- extract from eg, sec::4096:1:C910D9222512E3C7:... +listSecretKeys = mapMaybe parse . lines <$> readProcess "gpg" + ["--batch", "--with-colons", "--list-secret-keys"] "" + where + parse l = case splitOn ":" l of + ("sec":_:_:_:kid:_:_:_:_:n:_) -> Just + (Name (BU8.fromString n), KeyId (BU8.fromString kid)) + _ -> Nothing getSecretKey :: KeyId -> IO SecretKey -getSecretKey = undefined +getSecretKey (KeyId kid) = do + (_, Just hout, _, ph) <- createProcess (proc "gpg" ps) + { std_out = CreatePipe } + secretkey <- SecretKey <$> B.hGetContents hout + exitcode <- waitForProcess ph + case exitcode of + ExitSuccess -> return secretkey + _ -> error "gpg --export-secret-key failed" + where + ps = ["--batch", "--export-secret-key", BU8.toString kid] -- | Check if a given gpg key is present on the keyserver. -- (Without downloading the key.) diff --git a/Types/UI.hs b/Types/UI.hs index 561aa65..67b4c5f 100644 --- a/Types/UI.hs +++ b/Types/UI.hs @@ -10,8 +10,9 @@ import Types data UI = UI { isAvailable :: IO Bool , showError :: Desc -> IO () + , promptQuestion :: Title -> Desc -> IO Bool , promptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) - , promptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) + , promptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) , promptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) , withProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () } diff --git a/UI/Readline.hs b/UI/Readline.hs index 086da1e..ac962d2 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -12,14 +12,20 @@ import System.Posix.Terminal import System.Posix.IO import Control.Exception import System.IO +import Data.List +import Data.Char +import Text.Read +import Control.Monad import qualified Data.ByteString.UTF8 as BU8 readlineUI :: UI readlineUI = UI { isAvailable = queryTerminal stdInput , showError = myShowError + , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword + , promptKeyId = myPromptKeyId , withProgress = myWithProgress } @@ -27,6 +33,24 @@ myShowError :: Desc -> IO () myShowError desc = do hPutStrLn stderr $ "Error: " ++ desc +myPromptQuestion :: Title -> Desc -> IO Bool +myPromptQuestion title desc = do + showTitle title + go + where + go = do + putStrLn desc + mresp <- readline "y/n? " + case mresp of + Just s + | "y" `isPrefixOf` (map toLower s) -> + return True + | "n" `isPrefixOf` (map toLower s) -> + return False + _ -> do + putStrLn "Please enter 'y' or 'n'" + go + myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) myPromptName title desc (Name suggested) checkproblem = do showTitle title @@ -49,8 +73,8 @@ myPromptName title desc (Name suggested) checkproblem = do go Nothing -> return Nothing -myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -myPromptPassword title desc checkproblem = bracket setup teardown (const go) +myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) +myPromptPassword confirm title desc = bracket setup teardown (const prompt) where setup = do showTitle title @@ -60,11 +84,15 @@ myPromptPassword title desc checkproblem = bracket setup teardown (const go) setTerminalAttributes stdInput newattr Immediately return origattr teardown origattr = setTerminalAttributes stdInput origattr Immediately - go = do + prompt = do putStr "Enter password> " hFlush stdout p1 <- getLine putStrLn "" + if confirm + then promptconfirm p1 + else return $ mkpassword p1 + promptconfirm p1 = do putStr "Confirm password> " hFlush stdout p2 <- getLine @@ -72,16 +100,35 @@ myPromptPassword title desc checkproblem = bracket setup teardown (const go) if p1 /= p2 then do putStrLn "Passwords didn't match, try again..." - go - else - let p = Password $ BU8.fromString p1 - in case checkproblem p of - Nothing -> do - putStrLn "" - return $ Just p - Just problem -> do - putStrLn problem - go + prompt + else do + putStrLn "" + return $ mkpassword p1 + mkpassword = Just . Password . BU8.fromString + +myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) +myPromptKeyId _ _ [] = return Nothing +myPromptKeyId title desc l = do + showTitle title + putStrLn desc + putStrLn "" + forM_ nl $ \(n, ((Name name), (KeyId kid))) -> + putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ BU8.toString kid ++ ")" + prompt + where + nl = zip [1 :: Integer ..] l + prompt = do + putStr "Enter number> " + hFlush stdout + r <- getLine + putStrLn "" + case readMaybe r of + Just n + | n > 0 && n < length l -> + return $ Just $ snd (l !! n) + _ -> do + putStrLn $ "Enter a number from 1 to " ++ show (length l) + prompt myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () myWithProgress title desc a = bracket_ setup teardown (a sendpercent) diff --git a/UI/Zenity.hs b/UI/Zenity.hs index c8fca2d..3c3f313 100644 --- a/UI/Zenity.hs +++ b/UI/Zenity.hs @@ -23,8 +23,10 @@ zenityUI = UI loc <- filterM (\p -> doesFileExist (p </> "zenity")) ps return (not (null loc)) , showError = myShowError + , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword + , promptKeyId = myPromptKeyId , withProgress = myWithProgress } @@ -40,6 +42,16 @@ myShowError desc = bracket go cleanup (\_ -> return ()) _ <- waitZenity h return () +myPromptQuestion :: Title -> Desc -> IO Bool +myPromptQuestion title desc = do + h <- runZenity + [ "--question" + , "--title", title + , "--text", desc + ] + (_, ok) <- waitZenity h + return ok + myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) myPromptName title desc (Name suggested) checkproblem = go "" where @@ -59,31 +71,50 @@ myPromptName title desc (Name suggested) checkproblem = go "" Just problem -> go problem else return Nothing -myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -myPromptPassword title desc checkproblem = go "" +myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) +myPromptPassword confirm title desc = go "" where go extradesc = do - h <- runZenity + h <- runZenity $ [ "--forms" , "--title", title , "--text", desc ++ "\n" ++ extradesc ++ "\n" - , "--add-password", "Enter password" - , "--add-password", "Confirm password" , "--separator", "\BEL" - ] + , "--add-password", "Enter password" + ] ++ if confirm + then [ "--add-password", "Confirm password" ] + else [] (ret, ok) <- waitZenity h if ok - then - let (p1, _:p2) = break (== '\BEL') ret - in if p1 /= p2 - then go "Passwords didn't match, try again..." - else - let p = Password $ BU8.fromString p1 - in case checkproblem p of - Nothing -> return $ Just p - Just problem -> go problem + then if confirm + then + let (p1, _:p2) = break (== '\BEL') ret + in if p1 /= p2 + then go "Passwords didn't match, try again..." + else return $ Just $ Password $ BU8.fromString p1 + else return $ Just $ Password $ BU8.fromString ret else return Nothing +myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) +myPromptKeyId _ _ [] = return Nothing +myPromptKeyId title desc l = do + h <- runZenity $ + [ "--list" + , "--title", title + , "--text", desc + , "--column", "gpg secret key name" + , "--column", "keyid" + , "--print-column", "ALL" + , "--separator", "\BEL" + , "--width", "500" + ] ++ concatMap (\(Name n, KeyId kid) -> [BU8.toString n, BU8.toString kid]) l + (ret, ok) <- waitZenity h + if ok + then do + let (_n, _:kid) = break (== '\BEL') ret + return $ Just (KeyId (BU8.fromString kid)) + else return Nothing + myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () myWithProgress title desc a = bracket setup teardown (a . sendpercent) where diff --git a/keysafe.cabal b/keysafe.cabal index f92656a..866804e 100644 --- a/keysafe.cabal +++ b/keysafe.cabal @@ -31,6 +31,7 @@ Executable keysafe , utf8-string == 1.0.* , unix == 2.7.* , filepath == 1.4.* + , split == 0.2.* , directory == 1.2.* , process == 1.2.* , optparse-applicative == 0.12.* @@ -80,22 +80,30 @@ backup :: UI -> Tunables -> SecretKeySource -> SecretKey -> IO () backup ui tunables secretkeysource secretkey = do username <- userName name <- fromMaybe (error "Aborting on no name") - <$> promptName ui "Enter a name" + <$> promptName ui "Enter name" namedesc username validateName - password <- fromMaybe (error "Aborting on no password") - <$> promptPassword ui "Enter a password" - passworddesc validatePassword - kek <- genKeyEncryptionKey tunables name password - -- TODO: show password strength estimate, and verify password. - putStrLn "Very rough estimate of cost to brute-force the password:" - print $ estimateAttack spotAWS $ estimateBruteforceOf kek - (passwordEntropy password []) + kek <- getkek 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 where + getkek name = do + password <- fromMaybe (error "Aborting on no password") + <$> promptPassword ui True "Enter password" passworddesc + kek <- genKeyEncryptionKey tunables name password + username <- userName + let badwords = concatMap namewords [name, username] + let crackcost = estimateAttack spotAWS $ + estimateBruteforceOf kek $ + passwordEntropy password badwords + ok <- promptQuestion ui "Password strength estimate" $ + show crackcost + if ok + then return kek + else getkek name + namewords (Name nb) = words (BU8.toString nb) namedesc = unlines [ "To back up your secret key, you will need to enter a name and a password." , "" @@ -118,14 +126,19 @@ restore :: UI -> SecretKeySource -> IO () restore ui secretkeydest = do username <- userName name <- fromMaybe (error "Aborting on no name") - <$> promptName ui "Enter the name of the key to restore" + <$> promptName ui "Enter name" namedesc username validateName + password <- fromMaybe (error "Aborting on no password") + <$> 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) where @@ -134,24 +147,23 @@ restore ui secretkeydest = do Just (SecretKey sk) -> print sk Nothing -> go esk rest - password = Password "correct horse battery staple" -- TODO: derive by probing to find objects tunables = testModeTunables -- defaultTunables namedesc = unlines - [ "When you backed up the key, you entered a name and a password." + [ "When you backed up your secret key, you entered a name and a password." , "Now it's time to remember what you entered back then." , "" , "(If you can't remember the name you used, your own full name is the best guess.)" ] + passworddesc = unlines + [ "Enter the password to unlock your secret key." + ] validateName :: Name -> Maybe Problem validateName (Name n) | B.length n < 6 = Just "The name should be at least 6 letters long." | otherwise = Nothing -validatePassword :: Password -> Maybe Problem -validatePassword _ = Nothing - userName :: IO Name userName = do u <- getUserEntryForID =<< getEffectiveUserID |