Added basic test suite.

11 files changed, 190 insertions, 33 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 093e037..e9dc8c2 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -8,6 +8,7 @@ keysafe (0.20160820) UNRELEASED; urgency=medium
   * Fix gpg secret key list parser to support gpg 2.
   * Tuned argon2 hash parameters on better hardware than my fanless laptop.
   * Improve time estimates, taking into account the number of cores.
+  * Added basic test suite.
 
  -- Joey Hess <id@joeyh.name>  Mon, 22 Aug 2016 13:56:16 -0400
 
diff --git a/CmdLine.hs b/CmdLine.hs
index 62f6887..a8201c8 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -23,7 +23,7 @@ data CmdLine = CmdLine
 	, serverConfig :: ServerConfig
 	}
 
-data Mode = Backup | Restore | UploadQueued | Server | Benchmark
+data Mode = Backup | Restore | UploadQueued | Server | Benchmark | Test
 	deriving (Show)
 
 data ServerConfig = ServerConfig
@@ -33,7 +33,7 @@ data ServerConfig = ServerConfig
 
 parse :: Parser CmdLine
 parse = CmdLine
-	<$> optional (backup <|> restore <|> uploadqueued <|> server <|> benchmark)
+	<$> optional (backup <|> restore <|> uploadqueued <|> server <|> benchmark <|> test)
 	<*> optional (gpgswitch <|> fileswitch)
 	<*> localstorageswitch
 	<*> guiswitch
@@ -61,6 +61,10 @@ parse = CmdLine
 		( long "benchmark"
 		<> help "Benchmark speed of keysafe's cryptographic primitives."
 		)
+	test = flag' Test
+		( long "test"
+		<> help "Run test suite."
+		)
 	gpgswitch = GpgKey . KeyId . BU8.fromString <$> strOption
 		( long "gpgkeyid"
 		<> metavar "KEYID"
diff --git a/HTTP/Server.hs b/HTTP/Server.hs
index fa2e8da..3e0b9aa 100644
--- a/HTTP/Server.hs
+++ b/HTTP/Server.hs
@@ -40,7 +40,7 @@ runServer bindaddress port = do
 	host = fromString bindaddress
 
 serverStorage :: Storage
-serverStorage = localStorage "server"
+serverStorage = localStorage userStorageDir "server"
 
 app :: ServerState -> Application
 app st = serve userAPI (server st)
diff --git a/Storage.hs b/Storage.hs
index 85e52a6..c9446c5 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -24,7 +24,7 @@ allStorageLocations = do
 
 localStorageLocations :: StorageLocations
 localStorageLocations = StorageLocations $
-	map (localStorage . ("local" </>) . show)
+	map (localStorage userStorageDir . ("local" </>) . show)
 		[1..100 :: Int]
 
 type UpdateProgress = IO ()
diff --git a/Storage/Local.hs b/Storage/Local.hs
index e8f6010..d0a1d15 100644
--- a/Storage/Local.hs
+++ b/Storage/Local.hs
@@ -3,7 +3,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module Storage.Local (localStorage, uploadQueue) where
+module Storage.Local (localStorage, userStorageDir, testStorageDir, uploadQueue) where
 
 import Types
 import Types.Storage
@@ -23,25 +23,27 @@ import Control.DeepSeq
 import Control.Exception
 import Control.Monad
 
+type GetShareDir = Section -> IO FilePath
+
 newtype Section = Section String
 
-localStorage :: String -> Storage
-localStorage n = Storage
-	{ storeShare = store section
-	, retrieveShare = retrieve section
-	, obscureShares = obscure section
-	, countShares = count section
-	, moveShares = move section
+localStorage :: GetShareDir -> String -> Storage
+localStorage getsharedir n = Storage
+	{ storeShare = store section getsharedir
+	, retrieveShare = retrieve section getsharedir
+	, obscureShares = obscure section getsharedir
+	, countShares = count section getsharedir
+	, moveShares = move section getsharedir
 	}
   where
 	section = Section n
 
 uploadQueue :: Server -> Storage
-uploadQueue s = localStorage ("uploadqueue" </> serverName s)
+uploadQueue s = localStorage userStorageDir ("uploadqueue" </> serverName s)
 
-store :: Section -> StorableObjectIdent -> Share -> IO StoreResult
-store section i s = onError (StoreFailure . show) $ do
-	dir <- shareDir section
+store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult
+store section getsharedir i s = onError (StoreFailure . show) $ do
+	dir <- getsharedir section
 	createDirectoryIfMissing True dir
 	let dest = dir </> shareFile i
 	exists <- doesFileExist dest
@@ -57,9 +59,9 @@ store section i s = onError (StoreFailure . show) $ do
 			renameFile tmp dest
 			return StoreSuccess
 
-retrieve :: Section -> ShareNum -> StorableObjectIdent -> IO RetrieveResult
-retrieve section n i = onError (RetrieveFailure . show) $ do
-	dir <- shareDir section
+retrieve :: Section -> GetShareDir -> ShareNum -> StorableObjectIdent -> IO RetrieveResult
+retrieve section getsharedir n i = onError (RetrieveFailure . show) $ do
+	dir <- getsharedir section
 	fd <- openFd (dir </> shareFile i) ReadOnly Nothing defaultFileFlags
 	h <- fdToHandle fd
 	b <- B.hGetContents h
@@ -75,22 +77,22 @@ retrieve section n i = onError (RetrieveFailure . show) $ do
 --
 -- Note that the contents of shares is never changed, so it's ok to set the
 -- mtime to the epoch; backup programs won't be confused.
-obscure :: Section -> IO ObscureResult
-obscure section = onError (ObscureFailure . show) $ do
-	dir <- shareDir section
+obscure :: Section -> GetShareDir -> IO ObscureResult
+obscure section getsharedir = onError (ObscureFailure . show) $ do
+	dir <- getsharedir section
 	fs <- filter isShareFile <$> getDirectoryContents dir
 	mapM_ (\f -> setFileTimes (dir </> f) 0 0) fs
 	return ObscureSuccess
 
-count :: Section -> IO CountResult
-count section = onError (CountFailure . show) $ do
-	dir <- shareDir section
+count :: Section -> GetShareDir -> IO CountResult
+count section getsharedir = onError (CountFailure . show) $ do
+	dir <- getsharedir section
 	CountResult . genericLength . filter isShareFile
 		<$> getDirectoryContents dir
 
-move :: Section -> Storage -> IO ()
-move section storage = do
-	dir <- shareDir section
+move :: Section -> GetShareDir -> Storage -> IO ()
+move section getsharedir storage = do
+	dir <- getsharedir section
 	fs <- getDirectoryContents dir
 	forM_ fs $ \f -> case fromShareFile f of
 		Nothing -> return ()
@@ -99,7 +101,7 @@ move section storage = do
 			-- matter because we're not going to be
 			-- recombining the share, just sending its contents
 			-- on the the server.
-			r <- retrieve section 0 i
+			r <- retrieve section getsharedir 0 i
 			case r of
 				RetrieveFailure _ -> return ()
 				RetrieveSuccess share -> do
@@ -115,11 +117,14 @@ onError f a = do
 		Left e -> f e
 		Right r -> r
 
-shareDir :: Section -> IO FilePath
-shareDir (Section section) = do
+userStorageDir :: GetShareDir
+userStorageDir (Section section) = do
 	u <- getUserEntryForID =<< getEffectiveUserID
 	return $ homeDirectory u </> dotdir </> section
 
+testStorageDir :: FilePath -> GetShareDir
+testStorageDir tmpdir (Section section) = pure $ tmpdir </> section
+
 -- | The takeFileName ensures that, if the StorableObjectIdent somehow
 -- contains a path (eg starts with "../" or "/"), it is not allowed
 -- to point off outside the shareDir.
diff --git a/TODO b/TODO
index d0f2615..4abdb42 100644
--- a/TODO
+++ b/TODO
@@ -1,4 +1,3 @@
-* test suite (eg, test basic storage and restore of various size data)
 * improve restore progress bar points (update after every hash try)
 * If we retrieved enough shares successfully, but decrypt failed, must
   be a wrong password, so prompt for re-entry and retry with those shares.
diff --git a/Tests.hs b/Tests.hs
new file mode 100644
index 0000000..c0d1f56
--- /dev/null
+++ b/Tests.hs
@@ -0,0 +1,142 @@
+{-# 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
+
+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"
diff --git a/Tunables.hs b/Tunables.hs
index 3356516..0a317c5 100644
--- a/Tunables.hs
+++ b/Tunables.hs
@@ -81,6 +81,7 @@ data KeyEncryptionKeyTunable = KeyEncryptionKeyTunable
 data EncryptionTunable = UseAES256
 	deriving (Show)
 
+-- | Tunables used by default to backup.
 defaultTunables :: Tunables
 defaultTunables = Tunables
 	{ shareParams = ShareParams { totalObjects = 3, neededObjects = 2 }
diff --git a/Types.hs b/Types.hs
index a132f26..e129ea3 100644
--- a/Types.hs
+++ b/Types.hs
@@ -15,6 +15,7 @@ import GHC.Generics (Generic)
 
 -- | keysafe stores secret keys.
 newtype SecretKey = SecretKey B.ByteString
+	deriving (Eq)
 
 -- | The secret key, encrypted with a password, in fixed size chunks.
 data EncryptedSecretKey = EncryptedSecretKey [B.ByteString] (CostCalc BruteForceOp UnknownPassword)
diff --git a/keysafe.cabal b/keysafe.cabal
index 8648437..fa530dd 100644
--- a/keysafe.cabal
+++ b/keysafe.cabal
@@ -77,6 +77,7 @@ Executable keysafe
     Storage
     Storage.Local
     Storage.Network
+    Tests
     Tunables
     Types
     Types.Cost
diff --git a/keysafe.hs b/keysafe.hs
index 0f32ac1..3bb5793 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -14,6 +14,7 @@ import UI
 import Encryption
 import Entropy
 import ExpensiveHash
+import Tests
 import Cost
 import SecretKey
 import Share
@@ -69,6 +70,8 @@ dispatch cmdline ui storagelocations tunables possibletunables = do
 			(CmdLine.serverPort $ CmdLine.serverConfig cmdline)
 	go CmdLine.Benchmark _ =
 		benchmarkTunables tunables
+	go CmdLine.Test _ =
+		runTests
 
 backup :: StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
 backup storagelocations ui tunables secretkeysource secretkey = do
@@ -253,7 +256,7 @@ restore storagelocations ui possibletunables secretkeydest = do
 		]
 
 -- | Try each possible tunable until the initial set of 
--- shares are found, the return the shares, and
+-- shares are found, and return the shares, and
 -- ShareIdents to download subsequent sets.
 downloadInitialShares
 	:: StorageLocations