Added --chaff mode which uploads random junk to servers.

This is useful both to test the server throttling of uploads, and to make
it harder for servers to know if an object actually contains secret key
information.

This commit was sponsored by Brock Spratlen on Patreon.

1 files changed, 35 insertions, 1 deletions

diff --git a/Storage.hs b/Storage.hs
index 2e35972..6115f30 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -3,6 +3,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Storage (module Storage, module Types.Storage) where
 
 import Types
@@ -11,11 +13,16 @@ import Share
 import Storage.Local
 import Storage.Network
 import Servers
+import Tunables
 import Data.Maybe
 import Data.List
+import Data.Monoid
+import System.IO
 import System.FilePath
 import Control.Monad
+import Crypto.Random
 import qualified Data.Set as S
+import Network.Wai.Handler.Warp (Port)
 
 allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations
 allStorageLocations d = do
@@ -124,4 +131,31 @@ uploadQueued d = do
 	processresults (StoreFailure e:rs) c = processresults rs (e:c)
 	processresults (StoreAlreadyExists:rs) c =
 		processresults rs ("Unable to upload a share to a server due to a name conflict.":c)
-			
+
+storeChaff :: HostName -> Port -> IO ()
+storeChaff hn port = forever $ do
+	putStrLn $ "Sending chaff to " ++ hn ++ " (press ctrl-c to stop)"
+	putStrLn "Legend: + = successful upload, ! = upload failure"
+	rng <- (cprgCreate <$> createEntropyPool) :: IO SystemRNG
+	let (randomname, rng') = cprgGenerate 128 rng
+	-- It's ok the use the testModeTunables here because
+	-- the randomname is not something that can be feasibly guessed.
+	-- Prefix "random chaff" to the name to avoid ever using a name
+	-- that a real user might want to use.
+	let sis = shareIdents testModeTunables (Name $ "random chaff:" <> randomname) (KeyFile "random")
+	go sis rng' (concat (repeat knownObjectSizes))
+  where
+	server = networkStorage Nothing $ Server hn port
+	go _ _ [] = return ()
+	go sis rng (s:sizes) = do
+		let (b, rng') = cprgGenerate s rng
+		let share = Share 0 (StorableObject b)
+		let ident = StorableObjectIdent 
+		let (is, sis') = nextShareIdents sis
+		let i = head (S.toList is)
+		r <- storeShare server i share
+		case r of
+			StoreSuccess -> putStr "."
+			_ -> putStr "!"
+		hFlush stdout
+		go sis' rng' sizes