blob: d18628e0bac1a08081fcaa4253f32490e55ba0cb (
plain)
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
|
{-# LANGUAGE OverloadedStrings #-}
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Tests where
import Types
import Tunables
import Encryption
import Share
import Storage
import Storage.Local
import Control.Exception
import System.Directory
import System.Posix.Temp
import System.IO
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.ByteString as B
import qualified Data.Set as S
import Data.Monoid
type TestDesc = B.ByteString
type TestResult = Either String ()
type Test = (TestDesc, IO TestResult)
testSuccess :: IO TestResult
testSuccess = return $ Right ()
testFailed :: String -> IO TestResult
testFailed = return . Left
runTest :: Test -> IO Bool
runTest (d, t) = do
putStr $ "testing: " ++ show d ++ " ..."
hFlush stdout
r <- t
case r of
Right () -> do
putStrLn "ok"
return True
Left e -> do
putStrLn $ "failed: " ++ show e
return False
runTests :: IO ()
runTests = do
r <- mapM runTest tests
if all (== True) r
then putStrLn "All tests succeeded."
else error "Tests failed. Report a bug!"
tests :: [Test]
tests =
[ backupRestoreTest "very small" $
testSecretKey 1
, backupRestoreTest "full size" $
testSecretKey (objectSize testModeTunables)
, backupRestoreTest "two chunks" $
testSecretKey (objectSize testModeTunables + 1)
, backupRestoreTest "many chunks" $
testSecretKey (objectSize testModeTunables * 10)
, stableNamingTest "stable naming"
]
testSecretKey :: Int -> SecretKey
testSecretKey sz = SecretKey $ BU8.fromString $ take sz $ concatMap show [1..sz]
withTestStorageLocations :: (StorageLocations -> IO a) -> IO a
withTestStorageLocations a = bracket setup cleanup go
where
setup = mkdtemp "keysafe-test"
cleanup = removeDirectoryRecursive
go tmpdir = a $ StorageLocations $
map (localStorage (testStorageDir tmpdir) . show)
[1..100 :: Int]
-- | Test of backup and restore of a SecretKey.
backupRestoreTest :: TestDesc -> SecretKey -> Test
backupRestoreTest testdesc secretkey =
("backup and restore (" <> testdesc <> ")", runtest)
where
runtest = withTestStorageLocations $ \storagelocations -> do
backup storagelocations
restore storagelocations
backup storagelocations = do
kek <- genKeyEncryptionKey tunables name password
let esk = encrypt tunables kek secretkey
shares <- genShares esk tunables
let sis = shareIdents tunables name secretkeysource
_ <- storeShares storagelocations sis shares (return ())
return ()
restore storagelocations = do
let sis = shareIdents tunables name secretkeysource
(shares, sis') <- retrieveShares storagelocations sis (return ())
let candidatekeys = candidateKeyEncryptionKeys tunables name password
case combineShares tunables [shares] of
Left e -> testFailed e
Right esk -> restorerest storagelocations [shares] sis' $
tryDecrypt candidatekeys esk
restorerest storagelocations firstshares sis r = case r of
DecryptFailed -> testFailed "DecryptFailed"
DecryptSuccess restoredsecretkey ->
if restoredsecretkey == secretkey
then testSuccess
else testFailed "restore yielded different value than was backed up"
DecryptIncomplete kek -> do
(nextshares, sis') <- retrieveShares storagelocations sis (return ())
let shares = firstshares ++ [nextshares]
case combineShares tunables shares of
Left e -> testFailed e
Right esk -> restorerest storagelocations shares sis' $
decrypt kek esk
name = Name testdesc
password = Password "password"
secretkeysource = GpgKey (KeyId "dummy")
-- testModeTunables is used, to avoid this taking a very
-- long time to run.
tunables = testModeTunables
-- | It's important that StorableObjectIdent generation be stable;
-- any change to it will cause shards to get lost.
stableNamingTest :: TestDesc -> Test
stableNamingTest testdesc = (testdesc, runtest $ map snd knownTunings)
where
runtest [] = testFailed "not stable!"
runtest (tunables:rest) = do
let sis = shareIdents tunables name secretkeysource
if S.member knownvalue (head (identsStream sis))
then testSuccess
else runtest rest
name = Name "stable name"
secretkeysource = GpgKey (KeyId "stable keyid")
knownvalue = StorableObjectIdent "18b112da9108b4b5e21fa07cfc672e11688110e4c2dc56c8365f0de488cca8cb"
|