add cost estimates

6 files changed, 65 insertions, 20 deletions

diff --git a/Cost.hs b/Cost.hs
index 31f00a3..5aa349c 100644
--- a/Cost.hs
+++ b/Cost.hs
@@ -56,8 +56,8 @@ spotAWS = DataCenterPrice
 -- which is unlikely to be the case; typically there will be many more
 -- cores than GPUs. So, this underestimates the price to brute force
 -- operations which run faster on GPUs.
-estimateAttack :: DataCenterPrice -> Cost BruteForceOp -> Dollars
-estimateAttack dc opcost = centsToDollars $ costcents
+estimateAttackCost :: DataCenterPrice -> Cost BruteForceOp -> Dollars
+estimateAttackCost dc opcost = centsToDollars $ costcents
   where
 	(Seconds cpuseconds) = fst (totalCost opcost)
 	cpuyears = cpuseconds `div` (60*60*24*365)
@@ -70,7 +70,35 @@ newtype Cents = Cents Integer
 	deriving (Num, Integral, Enum, Real, Ord, Eq, Show)
 
 newtype Dollars = Dollars Integer
-	deriving (Num, Integral, Enum, Real, Ord, Eq, Show)
+	deriving (Num, Integral, Enum, Real, Ord, Eq)
+
+instance Show Dollars where
+	show (Dollars n) = go 
+		[ (1000000000000, "trillion")
+		, (1000000000, "billion")
+		, (1000000, "million")
+		, (1000, "thousand")
+		]
+	  where
+		go [] = "$" ++ show n
+		go ((d, u):us)
+			| n >= d = 
+				let n' = n `div` d
+				in "$" ++ show n' ++ " " ++ u
+			| otherwise = go us
 
 centsToDollars :: Cents -> Dollars
 centsToDollars (Cents c) = Dollars (c `div` 100)
+
+type Year = Integer
+
+-- | Apply Moore's law to show how a cost might vary over time.
+costOverTime :: Dollars -> Year -> [(Dollars, Year)]
+costOverTime (Dollars currcost) thisyear = 
+	(Dollars currcost, thisyear) : map calc otheryears
+  where
+	otheryears = [thisyear+1, thisyear+5, thisyear+10]
+	calc y = 
+		let monthdelta = (fromIntegral ((y * 12) - (thisyear * 12))) :: Double
+		    cost = floor $ fromIntegral currcost / 2 ** (monthdelta / 18)
+		in (Dollars cost, y)
diff --git a/Types/Cost.hs b/Types/Cost.hs
index 290fa25..2f181a2 100644
--- a/Types/Cost.hs
+++ b/Types/Cost.hs
@@ -12,13 +12,13 @@ import Utility.HumanTime
 -- | An estimated cost to perform an operation.
 data Cost op 
 	= CPUCost Seconds -- ^ using 1 CPU core
-	deriving (Show)
+	deriving (Show, Eq, Ord)
 
 unknownCost :: Cost op
 unknownCost = CPUCost (Seconds 0)
 
 newtype Seconds = Seconds Integer
-	deriving (Num)
+	deriving (Num, Eq, Ord)
 
 instance Show Seconds where
 	show (Seconds n) = fromDuration (Duration n)
diff --git a/Types/UI.hs b/Types/UI.hs
index 67b4c5f..0a0c789 100644
--- a/Types/UI.hs
+++ b/Types/UI.hs
@@ -10,7 +10,7 @@ import Types
 data UI = UI
 	{ isAvailable :: IO Bool
 	, showError :: Desc -> IO ()
-	, promptQuestion :: Title -> Desc -> IO Bool
+	, promptQuestion :: Title -> Desc -> Question -> IO Bool
 	, 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)
@@ -21,3 +21,4 @@ type Title = String
 type Desc = String
 type Percent = Int
 type Problem = String
+type Question = String
diff --git a/UI/Readline.hs b/UI/Readline.hs
index ac962d2..8a3c4ee 100644
--- a/UI/Readline.hs
+++ b/UI/Readline.hs
@@ -32,15 +32,16 @@ readlineUI = UI
 myShowError :: Desc -> IO ()
 myShowError desc = do
 	hPutStrLn stderr $ "Error: " ++ desc
+	putStrLn ""
 
-myPromptQuestion :: Title -> Desc -> IO Bool
-myPromptQuestion title desc = do
+myPromptQuestion :: Title -> Desc -> Question -> IO Bool
+myPromptQuestion title desc question = do
 	showTitle title
 	go
   where
 	go = do
 		putStrLn desc
-		mresp <- readline "y/n? "
+		mresp <- readline $ question ++ " [y/n] "
 		case mresp of
 			Just s
 				| "y" `isPrefixOf` (map toLower s) ->
diff --git a/UI/Zenity.hs b/UI/Zenity.hs
index 3c3f313..b74631f 100644
--- a/UI/Zenity.hs
+++ b/UI/Zenity.hs
@@ -42,12 +42,12 @@ myShowError desc = bracket go cleanup (\_ -> return ())
 		_ <- waitZenity h
 		return ()
 
-myPromptQuestion :: Title -> Desc -> IO Bool
-myPromptQuestion title desc = do
+myPromptQuestion :: Title -> Desc -> Question -> IO Bool
+myPromptQuestion title desc question = do
 	h <- runZenity
 		[ "--question"
 		, "--title", title
-		, "--text",  desc
+		, "--text",  desc ++ "\n" ++ question
 		]
 	(_, ok) <- waitZenity h
 	return ok
diff --git a/keysafe.hs b/keysafe.hs
index 7068e22..103388b 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -20,6 +20,8 @@ import Storage
 import Storage.LocalFiles
 import qualified Gpg
 import Data.Maybe
+import Data.Time.Clock
+import Data.Time.Calendar
 import Control.Monad
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as BU8
@@ -82,27 +84,36 @@ backup ui tunables secretkeysource secretkey = do
 	name <- fromMaybe (error "Aborting on no name") 
 		<$> promptName ui "Enter name"
 			namedesc username validateName
-	kek <- getkek name
+	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
   where
-	getkek name = do
+	promptkek 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 $
+		let crackcost = estimateAttackCost spotAWS $
 			estimateBruteforceOf kek $
 				passwordEntropy password badwords
-		ok <- promptQuestion ui "Password strength estimate" $
-			show crackcost
-		if ok
-			then return kek
-			else getkek name
+		let mincost = Dollars 100000
+		if crackcost < mincost
+			then do
+				showError ui $ "Weak password! It would cost less than " ++ show mincost ++ " to crack the password. Please think of a better one. More words would be good.."
+				promptkek 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
+					else promptkek 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."
@@ -121,6 +132,10 @@ backup ui tunables secretkeysource secretkey = do
 		, "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: " :
+		map (\(c, y) -> "  " ++ show y ++ ":\t" ++ show c)
+			(costOverTime crackcost thisyear)
 
 restore :: UI -> SecretKeySource -> IO ()
 restore ui secretkeydest = do