1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
{-# LANGUAGE OverloadedStrings #-}
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Main where
import Types
import Tunables
import qualified CmdLine
import UI
import Encryption
import Entropy
import ExpensiveHash
import Cost
import SecretKey
import Shard
import Storage
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)
main :: IO ()
main = do
cmdline <- CmdLine.get
ui <- selectUI (CmdLine.gui cmdline)
let mkt = CmdLine.customizeShardParams cmdline
(tunables, possibletunables) <- 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 (mkt testModeTunables, [mkt testModeTunables])
else return (mkt defaultTunables, map (mkt . snd) knownTunings)
dispatch cmdline ui tunables possibletunables
dispatch :: CmdLine.CmdLine -> UI -> Tunables -> [Tunables] -> IO ()
dispatch cmdline ui tunables possibletunables = do
mode <- CmdLine.selectMode cmdline
go mode (CmdLine.secretkeysource cmdline)
where
storage = CmdLine.storage cmdline
go CmdLine.Backup (Just secretkeysource) =
backup storage ui tunables secretkeysource
=<< getSecretKey secretkeysource
go CmdLine.Restore (Just secretkeydest) =
restore storage ui possibletunables secretkeydest
go CmdLine.Backup Nothing =
backup storage ui tunables Gpg.anyKey
=<< Gpg.getKeyToBackup ui
go CmdLine.Restore Nothing =
restore storage ui possibletunables Gpg.anyKey
go CmdLine.Benchmark _ =
benchmarkTunables tunables
backup :: Storage -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
backup storage ui tunables secretkeysource secretkey = do
username <- userName
name <- fromMaybe (error "Aborting on no name")
<$> promptName ui "Enter name"
namedesc username validateName
kek <- promptkek name
let sis = shardIdents tunables name secretkeysource
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 storage 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 storage ui tunables secretkeysource secretkey
where
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 = estimateAttackCost spotAWS $
estimateBruteforceOf kek $
passwordEntropy password badwords
let mincost = Dollars 100000
if crackcost < mincost
then do
showError ui $ "Weak password! It would cost only " ++ show crackcost ++ " 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."
, ""
, "Make sure to pick a name you will remember at some point in the future,"
, "perhaps years from now, when you will need to enter it with the same"
, "spelling and capitalization in order to restore your secret key."
, ""
, "(Your own full name is a pretty good choice for the name to enter here.)"
]
passworddesc = unlines
[ "Pick a password that will be used to protect your secret key."
, ""
, "It's very important that this password be hard to guess."
, ""
, "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: " :
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 :: Storage -> UI -> [Tunables] -> SecretKeySource -> IO ()
restore storage ui possibletunables secretkeydest = do
username <- userName
name <- fromMaybe (error "Aborting on no name")
<$> promptName ui "Enter name"
namedesc username validateName
password <- fromMaybe (error "Aborting on no password")
<$> promptPassword ui True "Enter password" passworddesc
let mksis tunables = shardIdents tunables name secretkeydest
(tunables, shards) <- downloadShards storage ui mksis possibletunables
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 -> do
setpercent 100
writeSecretKey secretkeydest secretkey
showInfo ui "Success" "Your secret key successfully restored!"
where
namedesc = unlines
[ "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."
]
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 :: Storage -> UI -> (Tunables -> ShardIdents) -> [Tunables] -> IO (Tunables, [Shard])
downloadShards storage ui mksis possibletunables =
bracket_ setup cleanup download
where
setup = return ()
download = withProgress ui "Downloading encrypted data" message (go possibletunables)
cleanup = obscureShards storage
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 = [50+step, 50+step*2..100]
mshards <- forM (zip percentsteps l) $ \(pct, (n, i)) -> do
r <- retrieveShard storage n i
case r of
RetrieveSuccess s -> do
_ <- setpercent pct
return (Just s)
RetrieveFailure f -> do
hPutStrLn stderr $
"warning: retrieval of shard " ++ show n ++ " failed: " ++ f
return Nothing
let shards = catMaybes mshards
if null shards
then go othertunables setpercent
else return (tunables, shards)
possiblesis = map mksis possibletunables
message = unlines
[ "This will probably take around "
++ showCostMinutes (mconcat $ map getCreationCost possiblesis)
, ""
, "(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)
| B.length n < 2 = Just "The name should be at least 2 letters long."
| otherwise = Nothing
userName :: IO Name
userName = do
u <- getUserEntryForID =<< getEffectiveUserID
return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)
|
