keysafe 0.20160831 → 0.20160914

raw patch · 30 files changed

+1414/−336 lines, 30 filesdep +SafeSemaphoredep +asyncdep +bloomfilter

Dependencies added: SafeSemaphore, async, bloomfilter, crypto-random, disk-free-space, fast-logger, lifted-base, token-bucket, unbounded-delays

Files

• BackupRecord.hs +79/−0
• Benchmark.hs +119/−0
• ByteStrings.hs +30/−0
• CHANGELOG +24/−0
• CmdLine.hs +33/−4
• Cost.hs +7/−6
• Encryption.hs +6/−25
• Entropy.hs +4/−4
• ExpensiveHash.hs +0/−61
• Gpg.hs +3/−1
• HTTP.hs +38/−20
• HTTP/Client.hs +92/−4
• HTTP/Logger.hs +25/−0
• HTTP/ProofOfWork.hs +173/−0
• HTTP/RateLimit.hs +419/−0
• HTTP/Server.hs +32/−20
• Servers.hs +21/−0
• Storage.hs +81/−23
• Storage/Local.hs +51/−23
• Storage/Network.hs +13/−90
• TODO +3/−11
• Tunables.hs +21/−0
• Types.hs +0/−3
• Types/Cost.hs +2/−2
• Types/Server.hs +16/−0
• Types/Storage.hs +4/−1
• UI.hs +2/−1
• UI/NonInteractive.hs +42/−0
• keysafe.cabal +21/−2
• keysafe.hs +53/−35

@@ -0,0 +1,79 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE DeriveGeneric, BangPatterns #-}++module BackupRecord where++import Types+import Types.Cost+import Types.Server+import GHC.Generics+import Data.Time.Clock.POSIX+import Data.Aeson+import Data.Maybe+import System.FilePath+import System.Directory+import System.Posix.User+import System.Posix.Files+import qualified Data.ByteString.Lazy as B++-- | Record of a backup.+--+-- If an attacker cracks the user's system and finds this stored+-- on it, it should not help them recover keys from keysafe.+-- +-- That's why the Name used is not included; as knowing the name lets+-- an attacker download shards and start password cracking.+--+-- Including the password entropy does let an attacker avoid trying+-- weak passwords and go right to passwords that are strong enough, but+-- this should only half the password crack time at worst.+data BackupRecord = BackupRecord+	{ backupDate :: POSIXTime+	, backupServers :: [HostName]+	, secretKeySource :: String+	, passwordEntropy :: Int+	} deriving (Show, Generic)++-- BackupRecord is serialized as JSON.+instance ToJSON BackupRecord+instance FromJSON BackupRecord++mkBackupRecord :: [Server] -> SecretKeySource -> Entropy UnknownPassword -> IO BackupRecord+mkBackupRecord servers sks (Entropy n) = BackupRecord+	<$> getPOSIXTime+	<*> pure (map serverName servers)+	<*> pure (show sks)+	<*> pure n++backupRecordFile :: IO FilePath+backupRecordFile = do+	u <- getUserEntryForID =<< getEffectiveUserID+	return $ homeDirectory u </> ".keysafe/backup.log"++readBackupRecords :: IO [BackupRecord]+readBackupRecords = do+	f <- backupRecordFile+	e <- doesFileExist f+	if e+		then fromMaybe [] . decode <$> B.readFile f+		else return []++storeBackupRecord :: BackupRecord -> IO ()+storeBackupRecord r = do+	!rs <- readBackupRecords+	f <- backupRecordFile+	let d = takeDirectory f+	createDirectoryIfMissing True d+	setFileMode d $+		ownerReadMode+			`unionFileModes` ownerWriteMode+			`unionFileModes` ownerExecuteMode+	setPermissions d +		$ setOwnerReadable True +			$ setOwnerWritable True +				$ setOwnerExecutable True emptyPermissions+	B.writeFile f $ encode (r:rs)

@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}++{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Benchmark where++import Types+import Tunables+import ExpensiveHash+import HTTP.ProofOfWork+import Cost+import Serialization ()+import qualified Data.ByteString.UTF8 as BU8+import qualified Crypto.Argon2 as Argon2+import Data.Time.Clock+import Control.DeepSeq+import Control.Monad+import Data.Monoid+import Data.Maybe++data BenchmarkResult t = BenchmarkResult { expectedBenchmark :: t, actualBenchmark :: t }++instance Show (BenchmarkResult (Cost op)) where+	show br = "   expected: " ++ showtime (expectedBenchmark br) ++ "s"+		++ "\tactual: " ++ showtime (actualBenchmark br) ++ "s"+	  where+		showtime (CPUCost (Seconds s) _) = +			show (fromRational s :: Double)++benchmarkExpensiveHash :: Int -> ExpensiveHashTunable -> IO (BenchmarkResult (Cost CreationOp))+benchmarkExpensiveHash rounds tunables =+	benchmarkExpensiveHash' rounds tunables (getexpected tunables)+  where+	getexpected (UseArgon2 cost _) = mapCost (* fromIntegral rounds) cost++benchmarkExpensiveHash' :: Int -> ExpensiveHashTunable -> Cost op -> IO (BenchmarkResult (Cost op))+benchmarkExpensiveHash' rounds tunables@(UseArgon2 _ hashopts) expected = do+	numcores <- fromIntegral . fromMaybe (error "Unknown number of physical cores.") +		<$> getNumCores+	start <- getCurrentTime+	forM_ [1..rounds] $ \n -> do+		-- Must vary the data being hashed to avoid laziness+		-- caching hash results.+		let base = BU8.fromString (show n)+		let ExpensiveHash _ t = expensiveHash tunables+			(Salt (GpgKey (KeyId (base <> "dummy"))))+			(base <> "himom")+		t `deepseq` return ()+	end <- getCurrentTime+	let diff = floor (end `diffUTCTime` start) :: Integer+	let maxthreads = Argon2.hashParallelism hashopts+	let actual = CPUCost (Seconds (fromIntegral diff)) +		(Divisibility $ fromIntegral maxthreads)+	-- The expected cost is for a single core, so adjust it+	-- based on the number of cores, up to a maximum of the number+	-- of threads that the hash is configred to use.+	let usedcores = min maxthreads numcores+	let adjustedexpected = mapCost (/ fromIntegral usedcores) expected+	return $ BenchmarkResult+		{ expectedBenchmark = adjustedexpected+		, actualBenchmark = actual+		}++benchmark :: NFData t => Int -> Cost CreationOp -> (Int -> IO t) -> IO (BenchmarkResult (Cost CreationOp))+benchmark rounds expected a = do+	start <- getCurrentTime+	forM_ [1..rounds] $ \n -> do+		v <- a n+		v `deepseq` return ()+	end <- getCurrentTime+	let diff = floor (end `diffUTCTime` start) :: Integer+	return $ BenchmarkResult+		{ expectedBenchmark = expected+		, actualBenchmark = CPUCost (Seconds (fromIntegral diff)) (Divisibility 1)+		}++benchmarkPoW :: Int  -> Seconds -> IO (BenchmarkResult (Cost CreationOp))+benchmarkPoW rounds seconds = do+	let Just mk = mkProofOfWorkRequirement seconds+	s <- newRequestIDSecret+	rid <- mkRequestID s+	benchmark rounds (CPUCost (seconds * fromIntegral rounds) (Divisibility 1))+		(return . genProofOfWork (mk rid))++benchmarkTunables :: Tunables -> IO ()+benchmarkTunables tunables = do+	putStrLn "/proc/cpuinfo:"+	putStrLn =<< readFile "/proc/cpuinfo"+	+	putStrLn "Benchmarking 1000 rounds of proof of work hash..."+	print =<< benchmarkExpensiveHash 1000 (proofOfWorkHashTunable 0)++	putStrLn "Benchmarking 60 rounds of 1 second proofs of work..."+	print =<< benchmarkPoW 60 (Seconds 1)+	+	putStrLn "Benchmarking 10 rounds of 8 second proofs of work..."+	print =<< benchmarkPoW 10 (Seconds 8)++	-- Rather than run all 256 rounds of this hash, which would+	-- probably take on the order of 1 hour, run only 16, and scale+	-- the expected cost accordingly.+	let normalrounds = 256 * randomSaltBytes (keyEncryptionKeyTunable tunables)+	putStrLn $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..."+	r <- benchmarkExpensiveHash' 16+		(keyEncryptionKeyHash $ keyEncryptionKeyTunable tunables)+		(mapCost (/ (fromIntegral normalrounds / 16)) $ randomSaltBytesBruteForceCost $ keyEncryptionKeyTunable tunables)+	print r+	putStrLn $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..."+	print $ BenchmarkResult+		{ expectedBenchmark = mapCost (* 16) (expectedBenchmark r)+		, actualBenchmark = mapCost (* 16) (actualBenchmark r)+		}++	putStrLn "Benchmarking 1 round of name generation hash..."+	print =<< benchmarkExpensiveHash 1+		(nameGenerationHash $ nameGenerationTunable tunables)

@@ -0,0 +1,30 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module ByteStrings where++import qualified Data.ByteString as B++allByteStringsOfLength :: Int -> [B.ByteString]+allByteStringsOfLength = go []+  where+	go ws n+		| n == 0 = return (B.pack ws)+		| otherwise = do+			w <- [0..255]+			go (w:ws) (n-1)++-- | Contains every possible byte strings, with shorter ones first.+allByteStrings :: [B.ByteString]+allByteStrings = concatMap allByteStringsOfLength [1..]++chunkByteString :: Int -> B.ByteString -> [B.ByteString]+chunkByteString n = go []+  where+	go cs b+		| B.length b <= n = reverse (b:cs)+		| otherwise = +			let (h, t) = B.splitAt n b+			in go (h:cs) t

@@ -1,3 +1,27 @@+keysafe (0.20160914) unstable; urgency=medium++  * Fix bug that prevented keysafe --server from running when there was no+    controlling terminal and zenity was not installed.+  * Added --name and --othername options.+  * Added proof of work to client/server protocol.+  * Server-side rate limiting and DOS protection.+  * server: Added --months-to-fill-half-disk option, defaulting to 12.+  * Several new dependencies.+  * Another fix to gpg secret key list parser.+  * Warn when uploads fail and are put in the upload queue.+  * Warn when --uploadqueued fails to upload to servers.+  * Fix --uploadqueued bug that prevented deletion of local queued file.+  * 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.+  * Store information about backed up keys in ~/.keysafe/backup.log+    This can be deleted by the user at any time, but it's useful+    in case a server is known to be compromised, or a problem is found+    with keysafe's implementation that makes a backup insecure.++ -- Joey Hess <id@joeyh.name>  Wed, 14 Sep 2016 17:08:55 -0400+ keysafe (0.20160831) unstable; urgency=medium    * Server implementation is ready for initial deployment.

@@ -7,6 +7,7 @@  import Types import Types.Storage+import Types.Server (HostName) import Tunables import qualified Gpg import Options.Applicative@@ -22,26 +23,31 @@ 	, gui :: Bool 	, testMode :: Bool 	, customShareParams :: Maybe ShareParams+	, name :: Maybe Name+	, othername :: Maybe Name 	, serverConfig :: ServerConfig 	} -data Mode = Backup | Restore | UploadQueued | Server | Benchmark | Test+data Mode = Backup | Restore | UploadQueued | Server | Chaff HostName | Benchmark | Test 	deriving (Show)  data ServerConfig = ServerConfig 	{ serverPort :: Port 	, serverAddress :: String+	, monthsToFillHalfDisk :: Integer 	}  parse :: Parser CmdLine parse = CmdLine-	<$> optional (backup <|> restore <|> uploadqueued <|> server <|> benchmark <|> test)+	<$> optional (backup <|> restore <|> uploadqueued <|> server <|> chaff <|> benchmark <|> test) 	<*> optional (gpgswitch <|> fileswitch) 	<*> localstorageswitch-	<*> localstoragedirectory+	<*> localstoragedirectoryopt 	<*> guiswitch 	<*> testmodeswitch 	<*> optional (ShareParams <$> totalobjects <*> neededobjects)+	<*> nameopt+	<*> othernameopt 	<*> serverconfig   where 	backup = flag' Backup@@ -60,6 +66,11 @@ 		( long "server" 		<> help "Run as a keysafe server, accepting objects and storing them to ~/.keysafe/objects/local/" 		)+	chaff = Chaff <$> strOption+		( long "chaff"+		<> metavar "HOSTNAME"+		<> help "Upload random data to a keysafe server."+		) 	benchmark = flag' Benchmark 		( long "benchmark" 		<> help "Benchmark speed of keysafe's cryptographic primitives."@@ -82,7 +93,7 @@ 		( long "store-local" 		<> help "Store data locally. (The default is to store data in the cloud.)" 		)-	localstoragedirectory = optional $ LocalStorageDirectory <$> option str+	localstoragedirectoryopt = optional $ LocalStorageDirectory <$> option str 		( long "store-directory" 		<> metavar "DIR" 		<> help "Where to store data locally. (default: ~/.keysafe/objects/)"@@ -105,6 +116,16 @@ 		<> metavar "N" 		<> help ("Configure the number of shares needed to restore. (default: " ++ show (neededObjects (shareParams defaultTunables)) ++ ") (When this option is used to back up a key, it must also be provided at restore time.)") 		)+	nameopt = optional $ Name . BU8.fromString <$> strOption+		( long "name"+		<> metavar "N"+		<> help "Specify name used for key backup/restore, avoiding the usual prompt."+		)+	othernameopt = optional $ Name . BU8.fromString <$> strOption+		( long "othername"+		<> metavar "N"+		<> help "Specify other name used for key backup/restore, avoiding the usual prompt."+		) 	serverconfig = ServerConfig 		<$> option auto 			( long "port"@@ -120,6 +141,14 @@ 			<> showDefault 			<> help "Address for server to bind to. (Use \"*\" to bind to all addresses.)" 			)+		<*> option auto+			( long "months-to-fill-half-disk"+			<> metavar "N"+			<> value 12+			<> showDefault+			<> help "Server rate-limits requests and requires proof of work, to avoid too many objects being stored. This is an lower bound on how long it could possibly take for half of the current disk space to be filled."+			)+ get :: IO CmdLine get = execParser opts   where

@@ -22,7 +22,7 @@ raiseCostPower :: Cost c -> Entropy e -> Cost c raiseCostPower c (Entropy e) = mapCost (* 2^e) c -mapCost :: (Integer -> Integer) -> Cost op -> Cost op+mapCost :: (Rational-> Rational) -> Cost op -> Cost op mapCost f (CPUCost (Seconds n) d) = CPUCost (Seconds (f n)) d  type NumCores = Integer@@ -30,14 +30,15 @@ showCostMinutes :: NumCores -> Cost op -> String showCostMinutes numcores (CPUCost (Seconds n) (Divisibility d)) 	| n' < 61 = "1 minute"-	| otherwise = show (n' `div` 60) ++ " minutes"+	| otherwise = show (n' / 60) ++ " minutes"   where-	n' = n `div` min numcores d+	n' :: Double+	n' = fromRational n / fromIntegral (min numcores d)  -- If an operation took n seconds on a number of cores, -- multiply to get the CPUCost, which is for a single core. coreCost :: NumCores -> Seconds -> Divisibility -> Cost op-coreCost cores (Seconds n) d = CPUCost (Seconds (cores * n)) d+coreCost cores (Seconds n) d = CPUCost (Seconds (fromIntegral cores * n)) d  castCost :: Cost a -> Cost b castCost (CPUCost s d) = CPUCost s d@@ -82,11 +83,11 @@ estimateAttackCost dc opcost = centsToDollars $ costcents   where 	(Seconds cpuseconds) = fst (totalCost opcost)-	cpuyears = cpuseconds `div` (60*60*24*365)+	cpuyears = cpuseconds / (60*60*24*365) 	costpercpuyear = Cents $ 		fromIntegral (instanceCostPerHour dc) * 24 * 365 			`div` (instanceCpuCores dc * instanceCpuCoreMultiplier dc)-	costcents = Cents cpuyears * costpercpuyear+	costcents = Cents (ceiling cpuyears) * costpercpuyear  newtype Cents = Cents Integer 	deriving (Num, Integral, Enum, Real, Ord, Eq, Show)

@@ -12,9 +12,11 @@ import Tunables import Cost import ExpensiveHash+import ByteStrings import Data.Monoid import Data.Maybe import Data.Word+import Control.Monad import qualified Raaz import qualified Raaz.Cipher.AES as Raaz import qualified Raaz.Cipher.Internal as Raaz@@ -31,7 +33,7 @@  encrypt :: Tunables -> KeyEncryptionKey -> SecretKey -> EncryptedSecretKey encrypt tunables kek (SecretKey secret) = -	EncryptedSecretKey (chunk (objectSize tunables) b) (keyBruteForceCalc kek)+	EncryptedSecretKey (chunkByteString (objectSize tunables) b) (keyBruteForceCalc kek)   where 	-- Raaz does not seem to provide a high-level interface 	-- for AES encryption, so use unsafeEncrypt. The use of @@ -138,24 +140,6 @@ 	saltprefixes = allByteStringsOfLength $  		randomSaltBytes $ keyEncryptionKeyTunable tunables -allByteStringsOfLength :: Int -> [B.ByteString]-allByteStringsOfLength = go []-  where-	go ws n-		| n == 0 = return (B.pack ws)-		| otherwise = do-			w <- [0..255]-			go (w:ws) (n-1)--chunk :: Int -> B.ByteString -> [B.ByteString]-chunk n = go []-  where-	go cs b-		| B.length b <= n = reverse (b:cs)-		| otherwise = -			let (h, t) = B.splitAt n b-			in go (h:cs) t- -- Use the sha256 of the name (truncated) as the IV. genIV :: Name -> Raaz.IV genIV (Name name) =@@ -168,13 +152,10 @@ type SaltPrefix = B.ByteString  genRandomSaltPrefix :: Raaz.SystemPRG -> Tunables -> IO SaltPrefix-genRandomSaltPrefix prg tunables = go [] -	(randomSaltBytes $ keyEncryptionKeyTunable tunables)+genRandomSaltPrefix prg tunables = B.pack <$> replicateM n randbyte   where-	go ws 0 = return (B.pack ws)-	go ws n = do-		b <- Raaz.random prg :: IO Word8-		go (b:ws) (n-1)+	n = randomSaltBytes $ keyEncryptionKeyTunable tunables+	randbyte = Raaz.random prg :: IO Word8  instance Raaz.Random Word8 

@@ -13,12 +13,12 @@ -- | Calculation of the entropy of a password. -- Uses zxcvbn so takes word lists, and other entropy weakening problems -- into account.-passwordEntropy :: Password -> UserDict -> Entropy UnknownPassword-passwordEntropy (Password p) userdict = Entropy $ floor $+calcPasswordEntropy :: Password -> UserDict -> Entropy UnknownPassword+calcPasswordEntropy (Password p) userdict = Entropy $ floor $ 	estimate (B.toString p) userdict  -- | Naive calculation of the entropy of a name. -- Assumes that the attacker is not targeting a particular list of names.-nameEntropy :: Name -> Entropy UnknownName-nameEntropy (Name n) = Entropy $ floor $+calcNameEntropy :: Name -> Entropy UnknownName+calcNameEntropy (Name n) = Entropy $ floor $ 	estimate (B.toString n) []

@@ -7,20 +7,14 @@  module ExpensiveHash where -import Types import Tunables import Cost import Serialization () import qualified Data.Text as T import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BU8 import qualified Crypto.Argon2 as Argon2 import Raaz.Core.Encode-import Data.Time.Clock-import Control.DeepSeq-import Control.Monad import Data.Monoid-import Data.Maybe  -- | A hash that is expensive to calculate. --@@ -46,58 +40,3 @@ 	argonsalt =  		let sb = toByteString s 		in sb <> B.replicate (8 - B.length sb ) 32--benchmarkExpensiveHash :: Int -> ExpensiveHashTunable -> Cost op -> IO (BenchmarkResult (Cost op))-benchmarkExpensiveHash rounds tunables@(UseArgon2 _ hashopts) expected = do-	numcores <- fromIntegral . fromMaybe (error "Unknown number of physical cores.") -		<$> getNumCores-	start <- getCurrentTime-	forM_ [1..rounds] $ \n -> do-		-- Must vary the data being hashed to avoid laziness-		-- caching hash results.-		let base = BU8.fromString (show n)-		let ExpensiveHash _ t = expensiveHash tunables-			(Salt (GpgKey (KeyId (base <> "dummy"))))-			(base <> "himom")-		t `deepseq` return ()-	end <- getCurrentTime-	let diff = floor $ end `diffUTCTime` start-	let maxthreads = Argon2.hashParallelism hashopts-	let actual = CPUCost (Seconds diff) (Divisibility $ fromIntegral maxthreads)-	-- The expected cost is for a single core, so adjust it-	-- based on the number of cores, up to a maximum of the number-	-- of threads that the hash is configred to use.-	let usedcores = min maxthreads numcores-	let adjustedexpected = mapCost (`div` fromIntegral usedcores) expected-	return $ BenchmarkResult-		{ expectedBenchmark = adjustedexpected-		, actualBenchmark = actual-		}--benchmarkTunables :: Tunables -> IO ()-benchmarkTunables tunables = do-	putStrLn "/proc/cpuinfo:"-	putStrLn =<< readFile "/proc/cpuinfo"-	-	-- Rather than run all 256 rounds of this hash, which would-	-- probably take on the order of 1 hour, run only 16, and scale-	-- the expected cost accordingly.-	let normalrounds = fromIntegral $ -		256 * randomSaltBytes (keyEncryptionKeyTunable tunables)-	putStrLn $ "Benchmarking 16/" ++ show normalrounds ++ " rounds of key encryption key hash..."-	r <- benchmarkExpensiveHash 16-		(keyEncryptionKeyHash $ keyEncryptionKeyTunable tunables)-		(mapCost (`div` (normalrounds `div` 16)) $ randomSaltBytesBruteForceCost $ keyEncryptionKeyTunable tunables)-	print r-	putStrLn $ "Estimated time for " ++ show normalrounds ++ " rounds of key encryption key hash..."-	print $ BenchmarkResult-		{ expectedBenchmark = mapCost (* 16) (expectedBenchmark r)-		, actualBenchmark = mapCost (* 16) (actualBenchmark r)-		}--	putStrLn "Benchmarking 1 round of name generation hash..."-	print =<< benchmarkExpensiveHash 1-		(nameGenerationHash $ nameGenerationTunable tunables)-		(getexpected $ nameGenerationHash $ nameGenerationTunable tunables)-  where-	getexpected (UseArgon2 cost _) = cost

@@ -42,8 +42,10 @@ 	parse = extract [] Nothing . map (splitOn ":") 	extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) = 		extract ((userid, keyid):c) Nothing rest-	extract c (Just keyid) rest =+	extract c (Just keyid) rest@(("sec":_):_) = 		extract (("", keyid):c) Nothing rest+	extract c (Just keyid) (_:rest) =+		extract c (Just keyid) rest 	extract c _ [] = c 	extract c _ (("sec":_:_:_:keyid:_):rest) = 		extract c (Just keyid) rest

@@ -14,55 +14,55 @@  import Types import Types.Storage+import HTTP.ProofOfWork import Serialization () import Servant.API import Data.Text import Data.Aeson.Types import GHC.Generics hiding (V1)+import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Raaz.Core.Encode as Raaz+import Data.Monoid+import Prelude  -- | Keysafe's http API type HttpAPI =  	"keysafe" :> V1 :> "motd" :> Get '[JSON] Motd 	:<|> "keysafe" :> V1 :> "objects" :> ObjectIdent :> POWParam-		:> Get '[JSON] (ProofOfWorkRequirement StorableObject)+		:> Get '[JSON] (POWGuarded StorableObject) 	:<|> "keysafe" :> V1 :> "objects" :> ObjectIdent :> POWParam 		:> ReqBody '[OctetStream] StorableObject-		:> Put '[JSON] (ProofOfWorkRequirement StoreResult)+		:> Put '[JSON] (POWGuarded StoreResult) 	:<|> "keysafe" :> V1 :> "stats" :> "countobjects" :> POWParam-		:> Get '[JSON] (ProofOfWorkRequirement CountResult)+		:> Get '[JSON] (POWGuarded CountResult)  type V1 = "v1"  newtype Motd = Motd Text 	deriving (Generic) -data ProofOfWorkRequirement t+data POWGuarded t 	= Result t-	| ProofOfWorkRequirement-		{ leadingZeros :: Int-		, argon2Iterations :: Int-		}+	| NeedProofOfWork ProofOfWorkRequirement 	deriving (Generic) -newtype ProofOfWork = ProofOfWork Text- type POWParam = QueryParam "proofofwork" ProofOfWork  type ObjectIdent = Capture "ident" StorableObjectIdent  instance ToJSON Motd instance FromJSON Motd-instance ToJSON t => ToJSON (ProofOfWorkRequirement t)-instance FromJSON t => FromJSON (ProofOfWorkRequirement t)--instance FromHttpApiData ProofOfWork where-	parseUrlPiece = Right . ProofOfWork-instance ToHttpApiData ProofOfWork where-	toUrlPiece (ProofOfWork t) = t+instance ToJSON t => ToJSON (POWGuarded t)+instance FromJSON t => FromJSON (POWGuarded t)+instance ToJSON ProofOfWorkRequirement+instance FromJSON ProofOfWorkRequirement+instance ToJSON RequestID+instance FromJSON RequestID+instance ToJSON RandomSalt+instance FromJSON RandomSalt  -- StorableObjectIdent contains a hash, which is valid UTF-8. instance ToHttpApiData StorableObjectIdent where@@ -84,10 +84,28 @@ 	parseJSON (Object v) = StorableObject <$> (unb64 =<< v .: "data") 	parseJSON invalid = typeMismatch "StorableObject" invalid +-- ProofOfWork contains an arbitrary bytestring and is base64 encoded in+-- the query string.+instance ToHttpApiData ProofOfWork where+	toUrlPiece (ProofOfWork b rid) =+		fromRandomSalt (randomSalt rid) +			<> ":" <> requestHMAC rid +			<> ":" <> b64 b+instance FromHttpApiData ProofOfWork where+	parseUrlPiece t = do+		let (salt, rest) = T.break (== ':') t+		let (hmac, rest') = T.break (== ':') (T.drop 1 rest)+		b <- unb64 (T.drop 1 rest')+		return $ ProofOfWork b $ RequestID+			{ randomSalt = RandomSalt salt+			, requestHMAC = hmac+			}+ b64 :: B.ByteString -> Text b64 v = T.decodeUtf8 $ Raaz.toByteString (Raaz.encode v :: Raaz.Base64)  unb64 :: Monad m => Text -> m B.ByteString-unb64 t = maybe (fail "bad base64 data") (return . Raaz.decodeFormat) f-  where-	f = Raaz.fromByteString (T.encodeUtf8 t) :: Maybe Raaz.Base64+unb64 t = maybe+	(fail "bad base64 data")+	(return . Raaz.decodeFormat)+	(Raaz.fromByteString (T.encodeUtf8 t) :: Maybe Raaz.Base64)

@@ -6,18 +6,106 @@ module HTTP.Client where  import HTTP+import HTTP.ProofOfWork import Types+import Types.Server+import Servers import Types.Storage+import Types.Cost import Servant.API import Servant.Client import Data.Proxy-import Network.HTTP.Client (Manager)+import Network.Wai.Handler.Warp (Port)+import Network.HTTP.Client hiding (port, host, Proxy)+import Network.HTTP.Client.Internal (Connection, makeConnection)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Exception+import qualified Network.Socket+import Network.Socket.ByteString (sendAll, recv)+import Network.Socks5+import qualified Data.ByteString.UTF8 as BU8+import Data.List+import Data.Char  httpAPI :: Proxy HttpAPI httpAPI = Proxy  motd :: Manager -> BaseUrl -> ClientM Motd-getObject :: StorableObjectIdent -> Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (ProofOfWorkRequirement StorableObject)-putObject :: StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Manager -> BaseUrl -> ClientM (ProofOfWorkRequirement StoreResult)-countObjects :: Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (ProofOfWorkRequirement CountResult)+getObject :: StorableObjectIdent -> Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (POWGuarded StorableObject)+putObject :: StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Manager -> BaseUrl -> ClientM (POWGuarded StoreResult)+countObjects :: Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (POWGuarded CountResult) motd :<|> getObject :<|> putObject :<|> countObjects = client httpAPI++tryA :: IO a -> IO (Either SomeException a)+tryA = try++serverRequest+	:: POWIdent p+	=> Server+	-> (String -> a)+	-> (r -> a)+	-> p+	-> (Maybe ProofOfWork -> Manager -> BaseUrl -> ExceptT ServantError IO (POWGuarded r))+	-> IO a+serverRequest srv onerr onsuccess p a = do+	r <- tryA $ go Nothing maxProofOfWork+	case r of+		Left e -> return $ onerr (show e)+		Right v -> return v+  where+	go pow (Seconds timeleft)+		| timeleft <= 0 = return $ onerr "server asked for too much proof of work; gave up"+		| otherwise = do+			res <- serverRequest' srv (a pow)+			case res of+				Left err -> return $ onerr err+				Right (Result r) -> return $ onsuccess r+				Right (NeedProofOfWork req) -> go+					(Just $ genProofOfWork req p)+					(Seconds timeleft - generationTime req)++serverRequest'+	:: Server+	-> (Manager -> BaseUrl -> ExceptT ServantError IO r)+	-> IO (Either String r)+serverRequest' srv a = do+	-- A new Manager is allocated for each request, rather than reusing+	-- any connection. This is a feature; it makes correlation attacks+	-- harder because the server can't tell if two connections+	-- accessing different objects came from the same user, except by+	-- comparing IP addresses (which are masked somewhat by using tor).+	manager <- torableManager+	res <- runExceptT $ a manager url+	return $ case res of+		Left err -> Left $ "server failure: " ++ show err+		Right r -> Right r+  where+	url = serverUrl srv++-- | HTTP Manager supporting tor .onion and regular hosts+torableManager :: IO Manager+torableManager = newManager $ defaultManagerSettings+	{ managerRawConnection = return conn+	}+  where+	conn addr host port+		| ".onion" `isSuffixOf` map toLower host = torConnection host port+		| otherwise = do+			regular <- managerRawConnection defaultManagerSettings+			regular addr host port++torConnection :: HostName -> Port -> IO Connection+torConnection onionaddress p = do+	(socket, _) <- socksConnect torsockconf socksaddr+	socketConnection socket 8192+  where+	torsocksport = 9050+	torsockconf = defaultSocksConf "127.0.0.1" torsocksport+	socksdomain = SocksAddrDomainName (BU8.fromString onionaddress)+	socksaddr = SocksAddress socksdomain (fromIntegral p)++socketConnection :: Network.Socket.Socket -> Int -> IO Connection+socketConnection socket chunksize = makeConnection+	(recv socket chunksize)+	(sendAll socket)+	(Network.Socket.close socket)

@@ -0,0 +1,25 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module HTTP.Logger where++import System.Log.FastLogger+import Data.String++data Logger = Logger LoggerSet LoggerSet++newLogger :: IO Logger+newLogger = Logger+	<$> newStdoutLoggerSet defaultBufSize+	<*> newStderrLoggerSet defaultBufSize++logStdout :: Logger -> String -> IO ()+logStdout (Logger l _) = sendLogger l++logStderr :: Logger -> String -> IO ()+logStderr (Logger _ l) = sendLogger l++sendLogger :: LoggerSet -> String -> IO ()+sendLogger l s = pushLogStrLn l (fromString s)

@@ -0,0 +1,173 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HTTP.ProofOfWork where++import Types+import Types.Cost+import ExpensiveHash+import Tunables+import ByteStrings+import GHC.Generics+import qualified Data.Text as T+import qualified Data.ByteString as B+import Data.Text.Encoding (encodeUtf8)+import Raaz.Core.Encode+import qualified Raaz+import Data.BloomFilter.Hash+import Control.Monad+import Control.DeepSeq+import Data.Word+import Data.Bits+import Data.Monoid+import Prelude++-- | A value that the client has to do some work to calculate.+data ProofOfWork = ProofOfWork B.ByteString RequestID+	deriving (Show, Generic)++instance NFData ProofOfWork++data ProofOfWorkRequirement = ProofOfWorkRequirement+	{ leadingZeros :: Int+	, addedArgon2Iterations :: Word32+	, requestID :: RequestID+	}+	deriving (Generic, Show)++-- | A request ID has two parts, a RandomSalt and a HMAC.+-- The server can verify if a request ID is one it generated.+data RequestID = RequestID+	{ randomSalt :: RandomSalt+	, requestHMAC :: T.Text+	}+	deriving (Generic, Show, Eq)++instance NFData RequestID++instance Hashable RequestID where+	hashIO32 = hashIO32 . hashRequestID+	hashIO64 = hashIO64 . hashRequestID++hashRequestID :: RequestID -> B.ByteString+hashRequestID rid = encodeUtf8 (fromRandomSalt (randomSalt rid)) +	<> ":" <> encodeUtf8 (requestHMAC rid)++-- | Using Text and not ByteString so that ProofOfWorkRequirement can have a+-- JSON instance.+newtype RandomSalt = RandomSalt { fromRandomSalt :: T.Text }+	deriving (Generic, Show, Eq)++instance NFData RandomSalt++-- | Servers should never demand a proof of work that takes longer than+-- this to generate. Note that if a server changes its mind and doubles+-- the proof of work, a client counts that cumulatively. So, a server+-- should avoid any single proof of work requirement taking more than half+-- this long.+maxProofOfWork :: Seconds+maxProofOfWork = Seconds (16*60)++-- | How long it will take to generate a proof of work meeting the+-- requirement, maximum.+--+-- Of course, a client can get lucky and find a value that works+-- on the very first try. On average, the client will need to work for half+-- as long as the returned number of Seconds.+generationTime :: ProofOfWorkRequirement -> Seconds+generationTime req = +	let UseArgon2 (CPUCost (Seconds s) _) _ = proofOfWorkHashTunable (addedArgon2Iterations req)+	in Seconds ((2^(leadingZeros req)) * s)++mkProofOfWorkRequirement :: Seconds -> Maybe (RequestID -> ProofOfWorkRequirement)+mkProofOfWorkRequirement (Seconds n)+	| lz < 1 = Nothing+	| otherwise = Just $ ProofOfWorkRequirement lz its+  where+	lz = floor (logBase 2 (fromRational (max 1 (n / s))) :: Double)+	UseArgon2 (CPUCost (Seconds s) _) _ = proofOfWorkHashTunable its+	its = 0++newtype RequestIDSecret = RequestIDSecret (Raaz.Key (Raaz.HMAC Raaz.SHA256))++newRequestIDSecret :: IO RequestIDSecret+newRequestIDSecret = do+	prg <- Raaz.newPRG () :: IO Raaz.SystemPRG+	RequestIDSecret <$> Raaz.random prg++mkRequestID :: RequestIDSecret -> IO RequestID+mkRequestID secret = mkRequeestID' secret <$> mkRandomSalt++mkRequeestID' :: RequestIDSecret -> RandomSalt -> RequestID+mkRequeestID' (RequestIDSecret key) salt =+	let hmac = Raaz.hmacSha256 key (encodeUtf8 $ fromRandomSalt salt)+	in RequestID salt (T.pack (showBase16 hmac))++validRequestID :: RequestIDSecret -> RequestID -> Bool+validRequestID secret rid =+	let rid' = mkRequeestID' secret (randomSalt rid)+	in requestHMAC rid == requestHMAC rid'++mkRandomSalt :: IO RandomSalt+mkRandomSalt = do+	prg <- Raaz.newPRG () :: IO Raaz.SystemPRG+	rs <- replicateM 16 (Raaz.random prg :: IO Word8)+	return $ RandomSalt $ T.pack $ concatMap show rs++instance Raaz.Random Word8++class POWIdent p where+	getPOWIdent :: p -> B.ByteString++instance POWIdent StorableObjectIdent where+	getPOWIdent (StorableObjectIdent i) = i++data NoPOWIdent = NoPOWIdent++instance POWIdent NoPOWIdent where+	getPOWIdent NoPOWIdent = B.empty++instance POWIdent Int where+	getPOWIdent = encodeUtf8 . T.pack . show++-- Note that this does not check validRequestID.+isValidProofOfWork :: POWIdent p => ProofOfWork -> ProofOfWorkRequirement -> p -> Bool+isValidProofOfWork (ProofOfWork pow rid) req p = samerequestids && enoughzeros+  where+	samerequestids = rid == requestID req+	enoughzeros = all (== False) (take (leadingZeros req) (setBits b))+	tunable = proofOfWorkHashTunable (addedArgon2Iterations req)+	salt = Salt $ POWSalt $+		encodeUtf8 (fromRandomSalt (randomSalt (requestID req))) <> pow+	ExpensiveHash _ hash = expensiveHash tunable salt (getPOWIdent p)+	-- Since expensiveHash generates an ascii encoded hash that+	-- includes the parameters, take the sha256 of it to get the+	-- bytestring that is what's checked for the neccesary number+	-- of leading 0 bits.+	b = Raaz.toByteString $ Raaz.sha256 $ encodeUtf8 hash++setBits :: B.ByteString -> [Bool]+setBits = concatMap go . B.unpack+  where+	go byte = map (uncurry testBit) (zip (repeat byte) [0..7])++newtype POWSalt = POWSalt B.ByteString++instance Encodable POWSalt where+	toByteString (POWSalt n) = n+	fromByteString = Just . POWSalt++genProofOfWork :: POWIdent p => ProofOfWorkRequirement -> p -> ProofOfWork+genProofOfWork req p = go allByteStrings+  where+	go [] = error "failed to generate Proof Of Work. This should be impossible!"+	go (b:bs)+		| isValidProofOfWork candidate req p = candidate+		| otherwise = go bs+	  where+		candidate = ProofOfWork b (requestID req)

@@ -0,0 +1,419 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module HTTP.RateLimit where++import Types.Cost+import HTTP+import HTTP.ProofOfWork+import HTTP.Logger+import Tunables+import CmdLine (ServerConfig(..))+import Types.Storage+import Storage.Local+import Servant+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.TokenBucket+import qualified Control.Concurrent.FairRWLock as FairRWLock+import Control.Concurrent.Thread.Delay+import qualified Data.BloomFilter.Mutable as BloomFilter+import qualified Data.BloomFilter.Hash as BloomFilter+import Data.BloomFilter.Easy (suggestSizing)+import Control.Monad+import Control.Monad.ST+import Control.Exception.Lifted (bracket)+import System.DiskSpace+import Data.Maybe+import Data.Word+import Control.Monad.IO.Class++-- | A rate limiter is a series of buckets. Each bucket has a+-- successively more difficult proof of work access requirement.+-- +-- To guard against DOS attacks that reuse the same proof of work,+-- bloom filters keep track of RequestIDs that have been used before.+data RateLimiter = RateLimiter+	{ buckets :: TMVar [Bucket]+	, unusedBuckets :: TMVar [Bucket]+	, fallbackQueue :: FallbackQueue+	, usedRequestIDs :: BloomFilter+	, usedRequestIDsOld :: BloomFilter+	, numUsedRequestIDs :: TMVar Int+	, requestIDSecret :: RequestIDSecret+	, requestCounter :: TMVar Integer+	}++type BloomFilter = TMVar (BloomFilter.MBloom RealWorld RequestID)++-- | Buckets fill up at a fixed rate, and accessing a bucket+-- removes one unit from it.+data Bucket = Bucket+	{ tokenBucket :: TokenBucket+	, proofOfWorkRequired :: Seconds+	, fillInterval :: Word64+	}++minFillInterval :: Word64+minFillInterval = 2 * 60 * 1000000 -- 1 token every other minute++-- | Size of the bucket. This allows a burst of accesses after an idle+-- period, which is especially useful when retrieving keys that were+-- split into multiple chunks. However, setting this too high lets clients+-- cheaply store lots of data on a server that has been idle for a while,+-- which could be an attractive way to abuse keysafe servers.+burstSize :: Word64+burstSize = 4 -- 256 kb immediate storage++newRateLimiter :: ServerConfig -> Maybe LocalStorageDirectory -> Logger -> IO RateLimiter+newRateLimiter cfg storedir logger = do+	rl <- RateLimiter +		<$> (newTMVarIO =<< mkbuckets (sdiv maxProofOfWork 2) [])+		<*> newTMVarIO []+		<*> newFallbackQueue+		<*> mkBloomFilter+		<*> mkBloomFilter+		<*> newTMVarIO 0+		<*> newRequestIDSecret+		<*> newTMVarIO 0+	_ <- forkIO (adjusterThread cfg storedir rl logger)+	return rl+  where+	-- The last bucket takes half of maxProofOfWork to access, and+	-- each earlier bucket quarters that time, down to the first bucket,+	-- which needs no proof of work. This ensures that in the edge case+	-- where a client keeps getting bumped up to more and more expensive+	-- buckets, it doesn't need to do more than maxProofOfWork total work.+	mkbuckets s@(Seconds n) bs+		| n <= 0 = finalbucket bs+		| otherwise = do+			case mkProofOfWorkRequirement s of+				Nothing -> finalbucket bs+				Just _ -> do+					b <- Bucket+						<$> newTokenBucket+						<*> pure s+						<*> pure minFillInterval+					mkbuckets (sdiv s 4) (b:bs)+	finalbucket bs = do+		b <- Bucket+			<$> newTokenBucket+			<*> pure (Seconds 0)+			<*> pure minFillInterval+		return (b:bs)++	sdiv (Seconds n) d = Seconds (n / d)++mkBloomFilter :: IO BloomFilter+mkBloomFilter = do+	b <- stToIO $ BloomFilter.new (BloomFilter.cheapHashes bloomhashes) bloomsize+	newTMVarIO b+  where+	-- Size the bloom filter to hold 1 million items, with a false+	-- positive rate of 1 in 100 thousand. This will use around 32 mb+	-- of memory.+	(bloomsize, bloomhashes) = suggestSizing bloomMaxSize (1/100000)++-- | Maximum number of RequestIDs that can be stored in a bloom filter+-- without the false positive rate getting bad.+bloomMaxSize :: Int+bloomMaxSize = 1000000++-- A request is tried in each bucket in turn which its proof of work allows+-- access to, until one is found that accepts it.+rateLimit :: POWIdent p => RateLimiter -> Logger -> Maybe ProofOfWork -> p -> Handler a -> Handler (POWGuarded a)+rateLimit ratelimiter logger mpow p a = do+	bs <- getBuckets ratelimiter+	validrequest <- liftIO $ checkValidRequestID ratelimiter logger mpow+	if validrequest+		then go bs+		else assignWork ratelimiter bs+  where+	go [] = fallback ratelimiter logger a+	go (b:bs) = case mkProofOfWorkRequirement (proofOfWorkRequired b) of+		Nothing -> checkbucket b bs+		Just mkreq -> case mpow of+			Nothing -> assignWork ratelimiter (b:bs)+			Just pow@(ProofOfWork _ rid) -> +				if isValidProofOfWork pow (mkreq rid) p+					then checkbucket b bs+					else assignWork ratelimiter (b:bs)+	checkbucket b bs = do+		allowed <- liftIO $ tokenBucketTryAlloc (tokenBucket b) +			burstSize (fillInterval b) 1+		if allowed+			then allowRequest ratelimiter a+			else go bs++checkValidRequestID :: RateLimiter -> Logger -> Maybe ProofOfWork -> IO Bool+checkValidRequestID _ _ Nothing = return True+checkValidRequestID rl logger (Just (ProofOfWork _ rid))+	| validRequestID (requestIDSecret rl) rid = do+		used <- iselem usedRequestIDs+		oldused <- iselem usedRequestIDsOld+		if not used && not oldused+			then do+				withBloomFilter rl usedRequestIDs+					(`BloomFilter.insert` rid)+				checkbloomsize+				return True+			else return False+	| otherwise = return False+  where+	iselem f = withBloomFilter rl f (BloomFilter.elem rid)++	checkbloomsize = do+		needrot <- atomically $ do+			n <- takeTMVar (numUsedRequestIDs rl)+			if n > bloomMaxSize `div` 2+				then return (Just n)+				else do+					putTMVar (numUsedRequestIDs rl) (n+1)+					return Nothing+		handlerotation needrot++	handlerotation Nothing = return ()+	handlerotation (Just n) = do+		logStderr logger $ "rotating bloom filters after processing " ++ show n ++ " requests"+		newused <- mkBloomFilter+		atomically $ do+			oldused <- takeTMVar (usedRequestIDs rl)+			putTMVar (usedRequestIDsOld rl) oldused+			putTMVar (usedRequestIDs rl) =<< takeTMVar newused+			putTMVar (numUsedRequestIDs rl) 0++assignWork :: RateLimiter -> [Bucket] -> Handler (POWGuarded a)+assignWork ratelimiter bs = +	case mapMaybe (mkProofOfWorkRequirement . proofOfWorkRequired) bs of+		[] -> throwError err404+		(mkreq:_) -> do+			rid <- liftIO $ mkRequestID $ requestIDSecret ratelimiter+			return $ NeedProofOfWork $ mkreq rid++withBloomFilter+	:: RateLimiter+	-> (RateLimiter -> BloomFilter)+	-> (BloomFilter.MBloom RealWorld RequestID -> ST RealWorld a)+	-> IO a+withBloomFilter rl field a = do+	b <- atomically $ readTMVar (field rl)+	stToIO (a b)++getBuckets :: MonadIO m => RateLimiter -> m [Bucket]+getBuckets = liftIO . atomically . readTMVar . buckets++putBuckets :: MonadIO m => RateLimiter -> [Bucket] -> m ()+putBuckets rl bs = liftIO $ atomically $ do+	_ <- takeTMVar (buckets rl)+	putTMVar (buckets rl) bs++-- The fallback queue is used when a client has provided a good enough+-- proof of work to access all buckets, but all are empty.+--+-- Only a limited number of requests can be in the queue, since they take+-- up server memory while blocked, and since too large a queue would stall+-- requests for too long.+--+-- Once in the queue, requests are run in FIFO order.+--+-- A separate bucket is used to rate limit requests in the fallback queue,+-- so requests in the queue do not need to contend with requests not in the+-- queue.+data FallbackQueue = FallbackQueue+	{ fallbackBucket :: TokenBucket+	, blockedRequestLock :: FairRWLock.RWLock+	, fallbackQueueSlots :: TMVar Int+	}++newFallbackQueue :: IO FallbackQueue+newFallbackQueue = FallbackQueue+	<$> newTokenBucket+	<*> FairRWLock.new+	<*> newTMVarIO 100++fallback :: RateLimiter -> Logger -> Handler a -> Handler (POWGuarded a)+fallback ratelimiter logger a = +	bracket (liftIO addq) (liftIO . removeq) go+  where+	q = fallbackQueueSlots (fallbackQueue ratelimiter)++	addq = liftIO $ atomically $ do+		n <- takeTMVar q+		if n <= 0+			then do+				putTMVar q n+				return False+			else do+				putTMVar q (n-1)+				return True++	removeq False = return ()+	removeq True = liftIO $ atomically $ do+		n <- takeTMVar q+		putTMVar q (n+1)+	+	-- tokenBucketWait is not fair, so use the blockedRequestLock+	-- to get fair FIFO ordering.+	waitbucket = do+		logStderr logger "** warning: All token buckets are empty. Delaying request.."+		FairRWLock.withWrite (blockedRequestLock (fallbackQueue ratelimiter)) $ do+			-- For simplicity, use the same fillInterval as the+			-- last bucket in the rate limiter for the fallback+			-- bucket.+			bs <- getBuckets ratelimiter+			case reverse bs of+				(lastb:_) -> tokenBucketWait+					(fallbackBucket (fallbackQueue ratelimiter)) +					burstSize (fillInterval lastb)+				[] -> return ()+	go False = giveup+	go True = do+		liftIO waitbucket+		allowRequest ratelimiter a+	+	giveup = do+		liftIO $ logStderr logger "** warning: All token buckets are empty and request queue is large; possible DOS attack? Rejected request.."+		assignWork ratelimiter =<< getBuckets ratelimiter++-- | How much data could be stored, in bytes per second, assuming all+-- buckets in the rate limiter being constantly drained by requests,+-- and all requests store objects.+maximumStorageRate :: RateLimiter -> IO Integer+maximumStorageRate ratelimiter = do+	bs <- getBuckets ratelimiter+	-- The last bucket is counted a second time, because the fallback+	-- request queue has its own bucket with the same characteristics+	-- as this bucket.+	let fallbackb = take 1 (reverse bs)+	return $ sum $ map calc (bs ++ fallbackb)+  where+	storesize = maximum knownObjectSizes+	calc b = fromIntegral $ +		(storesize * 1000000) `div` fromIntegral (fillInterval b)++describeRateLimiter :: RateLimiter -> IO String+describeRateLimiter ratelimiter = do+	storerate <- maximumStorageRate ratelimiter+	bs <- getBuckets ratelimiter+	return $ concat+		[ "rate limiter buckets: " ++ show bs+		, " ; maximum allowed storage rate: "+		, showBytes (storerate * 60 * 60 * 24 * 31) ++ "/month"+		]++showBytes :: Integer -> String+showBytes n+	| n <= 1024*1024 = show (n `div` 1024) ++ " KiB"+	| n <= 1024*1024*1024 = show (n `div` (1024 * 1024)) ++ " MiB"+	| otherwise = show (n `div` (1024 * 1024 * 1024)) ++ " GiB"++instance Show Bucket where+	show b = show (fillInterval b `div` (60 * 1000000)) ++ " Second/Request"+		++ " (PoW=" ++ show (proofOfWorkRequired b) ++ ")"++increaseDifficulty :: Logger -> RateLimiter -> IO ()+increaseDifficulty logger ratelimiter = do+	bs <- getBuckets ratelimiter+	case bs of+		[] -> unable+		(b:[])+			| fillInterval b < maxBound `div` 2 -> do+				-- Make the remaining bucket take longer to fill.+				let b' = b { fillInterval = fillInterval b * 2 }+				putBuckets ratelimiter [b']+				done+			| otherwise -> unable+		(b:rest) -> do+			-- Remove less expensive to access buckets,+			-- so that clients have to do some work.+			-- This is done first to cut off any freeloaders+			-- that may be abusing the keysafe server.+			atomically $ do+				unused <- takeTMVar (unusedBuckets ratelimiter)+				putTMVar (unusedBuckets ratelimiter) (b:unused)+			putBuckets ratelimiter rest+			done+  where+	unable = logStderr logger "Unable to increase difficulty any further!"+	done = do+		desc <- describeRateLimiter ratelimiter+		logStdout logger $ "increased difficulty -- " ++ desc++-- Should undo the effect of increaseDifficulty.+reduceDifficulty :: Logger -> RateLimiter -> IO ()+reduceDifficulty logger ratelimiter = do+	bs <- getBuckets ratelimiter+	case bs of+		(b:[]) | fillInterval b > minFillInterval -> do+			let b' = b { fillInterval = fillInterval b `div` 2 }+			putBuckets ratelimiter [b']+			done+		_ -> do+			mb <- getunused+			case mb of+				Nothing -> unable+				Just b -> do+					putBuckets ratelimiter (b:bs)+					done+  where+	getunused = atomically $ do+		unused <- takeTMVar (unusedBuckets ratelimiter)+		case unused of+			(b:bs) -> do+				putTMVar (unusedBuckets ratelimiter) bs+				return (Just b)+			[] -> do+				putTMVar (unusedBuckets ratelimiter) []+				return Nothing+	unable = return ()+	done = do+		desc <- describeRateLimiter ratelimiter+		logStdout logger $ "reduced difficulty -- " ++ desc++allowRequest :: RateLimiter -> Handler a -> Handler (POWGuarded a)+allowRequest ratelimiter a = do+	liftIO $ addRequest ratelimiter 1+	Result <$> a++addRequest :: RateLimiter -> Integer -> IO ()+addRequest ratelimiter n = liftIO $ atomically $ do+	v <- takeTMVar c+	putTMVar c (v + n)+  where+	c = requestCounter ratelimiter++-- Thread that wakes up periodically and checks the request rate+-- against the available disk space. If the disk is filling too quickly,+-- the difficulty is increased.+adjusterThread :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> Logger -> IO ()+adjusterThread cfg storedir ratelimiter logger = forever $ do+	delay (1000000 * intervalsecs)+	checkRequestRate cfg storedir ratelimiter logger intervalsecs+  where+	intervalsecs = 60*60++checkRequestRate :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> Logger -> Integer -> IO ()+checkRequestRate cfg storedir ratelimiter logger intervalsecs = do+	let storesize = maximum knownObjectSizes+	n <- liftIO $ atomically $ swapTMVar (requestCounter ratelimiter) 0+	let maxstoredinterval = n * fromIntegral storesize+	let maxstoredthismonth = maxstoredinterval * (intervalsecs `div` (60*60)) * 24 * 31+	freespace <- diskFree <$> localDiskUsage storedir+	let target = monthsToFillHalfDisk cfg+	let estimate = if maxstoredthismonth <= 0 +		then 10000+		else freespace `div` maxstoredthismonth `div` 2+	logStdout logger $ unlines+		[ "rate limit check"+		, "  free disk space:" ++ showBytes freespace+		, "  number of requests since last check: " ++ show n+		, "  estimated max incoming data in the next month: " ++ showBytes maxstoredthismonth+		, "  estimate min " ++ show estimate ++ " months to fill half of disk"+		]+	if estimate > target * 2+		then reduceDifficulty logger ratelimiter+		else if estimate < target+			then increaseDifficulty logger ratelimiter+			else return ()

@@ -8,9 +8,13 @@ module HTTP.Server (runServer) where  import HTTP+import HTTP.ProofOfWork+import HTTP.RateLimit+import HTTP.Logger import Types import Types.Storage import Tunables+import CmdLine (ServerConfig(..)) import Storage.Local import Serialization () import Servant@@ -18,6 +22,7 @@ import Network.Wai.Handler.Warp import Control.Monad.IO.Class import Control.Concurrent+import Control.Concurrent.Thread.Delay import Control.Concurrent.STM import Data.String import qualified Data.ByteString as B@@ -25,21 +30,27 @@ data ServerState = ServerState 	{ obscurerRequest :: TMVar () 	, storageDirectory :: Maybe LocalStorageDirectory+	, rateLimiter :: RateLimiter+	, logger :: Logger 	} -newServerState :: Maybe LocalStorageDirectory -> IO ServerState-newServerState d = ServerState-	<$> newEmptyTMVarIO-	<*> pure d+newServerState :: Maybe LocalStorageDirectory -> ServerConfig -> IO ServerState+newServerState d cfg = do+	l <- newLogger+	ServerState+		<$> newEmptyTMVarIO+		<*> pure d+		<*> newRateLimiter cfg d l+		<*> pure l -runServer :: Maybe LocalStorageDirectory -> String -> Port -> IO ()-runServer d bindaddress port = do-	st <- newServerState d+runServer :: Maybe LocalStorageDirectory -> ServerConfig -> IO ()+runServer d cfg = do+	st <- newServerState d cfg 	_ <- forkIO $ obscurerThread st 	runSettings settings (app st)   where-	settings = setHost host $ setPort port $ defaultSettings -	host = fromString bindaddress+	settings = setHost host $ setPort (serverPort cfg) $ defaultSettings +	host = fromString (serverAddress cfg)  serverStorage :: ServerState -> Storage serverStorage st = localStorage (storageDir $ storageDirectory st) "server"@@ -59,30 +70,31 @@ motd :: Handler Motd motd = return $ Motd "Hello World!" -getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement StorableObject)-getObject st i _pow = do+getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (POWGuarded StorableObject)+getObject st i pow = rateLimit (rateLimiter st) (logger st) pow i $ do 	r <- liftIO $ retrieveShare (serverStorage st) dummyShareNum i 	liftIO $ requestObscure st 	case r of-		RetrieveSuccess (Share _n o) -> return $ Result o+		RetrieveSuccess (Share _n o) -> return o 		RetrieveFailure _ -> throwError err404 -putObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (ProofOfWorkRequirement StoreResult)-putObject st i _pow o = do+putObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (POWGuarded StoreResult)+putObject st i pow o = rateLimit (rateLimiter st) (logger st) pow i $ do 	if validObjectsize o 		then do 			r <- liftIO $ storeShare (serverStorage st) i (Share dummyShareNum o) 			liftIO $ requestObscure st-			return $ Result r-		else return $ Result $ StoreFailure "invalid object size"+			return r+		else return $ StoreFailure "invalid object size"  validObjectsize :: StorableObject -> Bool validObjectsize o = any (sz ==) knownObjectSizes   where 	sz = B.length (fromStorableObject o) -countObjects :: ServerState -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement CountResult)-countObjects st _pow = liftIO $ Result <$> countShares (serverStorage st)+countObjects :: ServerState -> Maybe ProofOfWork -> Handler (POWGuarded CountResult)+countObjects st pow = rateLimit (rateLimiter st) (logger st) pow NoPOWIdent $+	liftIO $ countShares $ serverStorage st  -- | 1 is a dummy value; the server does not know the actual share numbers. dummyShareNum :: ShareNum@@ -94,8 +106,8 @@ obscurerThread :: ServerState -> IO () obscurerThread st = do 	_ <- obscureShares (serverStorage st)-	putStrLn "obscured shares"-	threadDelay (1000000*60*30)+	logStdout (logger st) "obscured shares"+	delay (1000000*60*30) 	_ <- atomically $ takeTMVar (obscurerRequest st) 	obscurerThread st 

@@ -0,0 +1,21 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Servers where++import Types.Server+import Servant.Client++serverUrl :: Server -> BaseUrl+serverUrl srv = BaseUrl Http (serverName srv) (serverPort srv) ""++-- | These can be either tor .onion addresses, or regular hostnames.+-- Using tor is highly recommended, to avoid correlation attacks.+networkServers :: IO [Server]+networkServers = return +	[ Server "vzgrspuxbtnlrtup.onion" 4242 -- keysafe.joeyh.name+	, Server "localhost" 4242+	, Server "localhost" 4242+	]

@@ -3,24 +3,33 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Storage (module Storage, module Types.Storage) where  import Types import Types.Storage+import Types.Server import Share import Storage.Local import Storage.Network-import Data.Monoid+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 Control.Concurrent.Async import qualified Data.Set as S+import Network.Wai.Handler.Warp (Port)  allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations allStorageLocations d = do 	servers <- networkServers-	return $ StorageLocations $-		map networkStorage servers <> map (uploadQueue d) servers+	return $ StorageLocations $ map (networkStorage d) servers  localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations localStorageLocations d = StorageLocations $@@ -32,37 +41,48 @@ -- | Stores the shares amoung the storage locations. Each location -- gets at most one share from each set. --+-- If a server is not currently accessible, it will be queued locally.+-- If this happens at all, returns True.+-- -- TODO: Add shuffling and queueing/chaffing to prevent -- correlation of related shares.-storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO StoreResult+storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO (StoreResult, Bool, [Storage]) storeShares (StorageLocations locs) allsis shares updateprogress = do-	(r, usedlocs) <- go allsis shares []+	((r, anyqueued), usedlocs) <- go allsis shares [] False 	_ <- mapM_ obscureShares usedlocs-	return r+	return (r, anyqueued, usedlocs)   where-	go sis (s:rest) usedlocs = do+	go sis (s:rest) usedlocs anyqueued = do 		let (is, sis') = nextShareIdents sis-		(r, usedlocs') <- storeset locs [] Nothing (zip (S.toList is) (S.toList s))+		(r, usedlocs', queued) <- storeset locs [] Nothing (zip (S.toList is) (S.toList s)) False 		case r of-			StoreSuccess -> go sis' rest (usedlocs ++ usedlocs')-			_ -> return (r, usedlocs ++ usedlocs')-	go _ [] usedlocs = return (StoreSuccess, usedlocs)+			StoreSuccess -> go sis' rest (usedlocs ++ usedlocs') (anyqueued || queued)+			_ -> return ((r, anyqueued || queued), usedlocs ++ usedlocs')+	go _ [] usedlocs anyqueued = return ((StoreSuccess, anyqueued), usedlocs) -	storeset _ usedlocs _ [] = return (StoreSuccess, usedlocs)-	storeset [] usedlocs lasterr _ =-		return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs)-	storeset (loc:otherlocs) usedlocs _ ((i, s):rest) = do+	storeset _ usedlocs _ [] queued = return (StoreSuccess, usedlocs, queued)+	storeset [] usedlocs lasterr _ queued =+		return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs, queued)+	storeset (loc:otherlocs) usedlocs _ ((i, s):rest) queued = do 		r <- storeShare loc i s 		case r of 			StoreSuccess -> do 				_ <- updateprogress-				storeset otherlocs (loc:usedlocs) Nothing rest+				storeset otherlocs (loc:usedlocs) Nothing rest queued 			-- Give up if any location complains a share 			-- already exists, because we have a name conflict.-			StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs)-			-- Try storing it somewhere else on failure.-			StoreFailure _ ->-				storeset otherlocs usedlocs (Just r) ((i, s):rest)+			StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs, queued)+			-- Queue or try storing it somewhere else on failure.+			StoreFailure _ -> case uploadQueue loc of+				Just q -> do+					r' <- storeShare q i s+					case r' of+						StoreSuccess -> do+							_ <- updateprogress+							storeset otherlocs (loc:usedlocs) Nothing rest True+						StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs, queued)+						StoreFailure _ -> storeset otherlocs usedlocs (Just r) ((i, s):rest) queued+				Nothing -> storeset otherlocs usedlocs (Just r) ((i, s):rest) queued  -- | Retrieves one set of shares from the storage locations. -- Returns all the shares it can find, which may not be enough,@@ -99,7 +119,45 @@ 				-- all of them. 				go (unusedlocs++[loc]) usedlocs' rest shares' -uploadQueued :: Maybe LocalStorageDirectory -> IO ()+-- | Returns descriptions of any failures.+uploadQueued :: Maybe LocalStorageDirectory -> IO [String] uploadQueued d = do-	servers <- networkServers-	forM_ servers $ \s -> moveShares (uploadQueue d s) (networkStorage s)+	StorageLocations locs <- allStorageLocations d+	results <- forM locs $ \loc -> case uploadQueue loc of+		Nothing -> return []+		Just q -> moveShares q loc+	return $ processresults (concat results) []+  where+	processresults [] c = nub c+	processresults (StoreSuccess:rs) c = processresults rs c+	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")+	mapConcurrently (go sis rng' (concat (repeat knownObjectSizes)))+		[1..totalObjects (shareParams testModeTunables)]+  where+	server = networkStorage Nothing $ Server hn port+	go _ _ [] _ = return ()+	go sis rng (s:sizes) n = do+		let (b, rng') = cprgGenerate s rng+		let share = Share 0 (StorableObject b)+		let (is, sis') = nextShareIdents sis+		let i = S.toList is !! (n - 1)+		r <- storeShare server i share+		case r of+			StoreSuccess -> putStr "+"+			_ -> putStr "!"+		hFlush stdout+		go sis' rng' sizes n

@@ -3,16 +3,21 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -module Storage.Local (localStorage, storageDir, testStorageDir, uploadQueue) where+module Storage.Local+	( localStorage+	, storageDir+	, testStorageDir+	, localDiskUsage+	) where  import Types import Types.Storage-import Storage.Network (Server(..)) import Serialization () import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as U8 import Data.Monoid import Data.List+import Data.Maybe import System.Posix.User import System.IO import System.Directory@@ -22,6 +27,7 @@ import Control.DeepSeq import Control.Exception import Control.Monad+import System.DiskSpace  type GetShareDir = Section -> IO FilePath @@ -34,13 +40,12 @@ 	, obscureShares = obscure section getsharedir 	, countShares = count section getsharedir 	, moveShares = move section getsharedir+	, uploadQueue = Nothing+	, getServer = Nothing 	}   where 	section = Section n -uploadQueue :: Maybe LocalStorageDirectory -> Server -> Storage-uploadQueue d s = localStorage (storageDir d) ("uploadqueue" </> serverName s)- store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult store section getsharedir i s = onError (StoreFailure . show) $ do 	dir <- getsharedir section@@ -90,26 +95,44 @@ 	CountResult . genericLength . filter isShareFile 		<$> getDirectoryContents dir -move :: Section -> GetShareDir -> Storage -> IO ()+move :: Section -> GetShareDir -> Storage -> IO [StoreResult] move section getsharedir storage = do 	dir <- getsharedir section-	fs <- getDirectoryContents dir-	forM_ fs $ \f -> case fromShareFile f of-		Nothing -> return ()-		Just i -> do-			-- Use a dummy share number of 0; it doesn't-			-- matter because we're not going to be-			-- recombining the share, just sending its contents-			-- on the the server.-			r <- retrieve section getsharedir 0 i-			case r of-				RetrieveFailure _ -> return ()-				RetrieveSuccess share -> do-					s <- storeShare storage i share-					case s of-						StoreFailure _ -> return ()-						_ -> removeFile f+	fs <- map (dir </>) <$> getDirectoryContents dir+	rs <- forM fs $ \f -> case fromShareFile f of+		Nothing -> return Nothing+		Just i -> Just <$> go f i+	return (catMaybes rs)+  where+	-- Use a dummy share number of 0; it doesn't+	-- matter because we're not going to be+	-- recombining the share here.+	sharenum = 0 +	go f i = do+		r <- retrieve section getsharedir sharenum i+		case r of+			RetrieveFailure e -> return (StoreFailure e)+			RetrieveSuccess share -> do+				s <- storeShare storage i share+				case s of+					StoreSuccess -> movesuccess f+					StoreAlreadyExists -> alreadyexists share i f+					StoreFailure e -> return (StoreFailure e)++	movesuccess f = do+		removeFile f+		return StoreSuccess++	-- Detect case where the same data is already+	-- stored on the other storage.+	alreadyexists share i f = do+		check <- retrieveShare storage sharenum i+		case check of+			RetrieveSuccess share'+				| share' == share -> movesuccess f+			_ -> return StoreAlreadyExists+ onError :: (IOException -> a) -> IO a -> IO a onError f a = do 	v <- try a@@ -127,6 +150,11 @@ testStorageDir :: FilePath -> GetShareDir testStorageDir tmpdir = storageDir (Just (LocalStorageDirectory tmpdir)) +localDiskUsage :: Maybe LocalStorageDirectory -> IO DiskUsage+localDiskUsage lsd = do+	dir <- storageDir lsd (Section ".")+	getDiskUsage dir+ -- | 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.@@ -135,7 +163,7 @@  fromShareFile :: FilePath -> Maybe StorableObjectIdent fromShareFile f-	| isShareFile f = fromByteString $ U8.fromString $ dropExtension f+	| isShareFile f = fromByteString $ U8.fromString $ takeFileName $ dropExtension f 	| otherwise = Nothing  isShareFile :: FilePath -> Bool

@@ -6,64 +6,37 @@ {-# LANGUAGE OverloadedStrings #-}  module Storage.Network (-	Server(..),-	networkServers, 	networkStorage,-	torableManager ) where  import Types import Types.Storage-import Data.List-import Data.Char-import HTTP+import Types.Server+import Storage.Local import HTTP.Client-import Servant.Client-import Network.Wai.Handler.Warp (Port)-import Network.HTTP.Client hiding (port, host)-import Network.HTTP.Client.Internal (Connection, makeConnection)-import Control.Monad.Trans.Except (ExceptT, runExceptT)-import qualified Network.Socket-import Network.Socket.ByteString (sendAll, recv)-import Network.Socks5-import qualified Data.ByteString.UTF8 as BU8--type HostName = String--data Server = Server-	{ serverName :: HostName-	, serverPort :: Port-	}--serverUrl :: Server -> BaseUrl-serverUrl srv = BaseUrl Http (serverName srv) (serverPort srv) ""---- | These can be either tor .onion addresses, or regular hostnames.--- Using tor is highly recommended, to avoid correlation attacks.-networkServers :: IO [Server]-networkServers = return -	[ Server "localhost" 4242-	, Server "localhost" 4242-	, Server "localhost" 4242-	]+import HTTP.ProofOfWork+import System.FilePath -networkStorage :: Server -> Storage-networkStorage server = Storage+networkStorage :: Maybe LocalStorageDirectory -> Server -> Storage+networkStorage localdir server = Storage 	{ storeShare = store server 	, retrieveShare = retrieve server 	, obscureShares = obscure server 	, countShares = count server 	, moveShares = move server+	, uploadQueue = Just $ localStorage (storageDir localdir)+		("uploadqueue" </> serverName server)+	, getServer = Just server 	}  store :: Server -> StorableObjectIdent -> Share -> IO StoreResult store srv i (Share _n o) = -	serverRequest srv StoreFailure id $ \pow ->+	serverRequest srv StoreFailure id i $ \pow -> 		putObject i pow o  retrieve :: Server -> ShareNum -> StorableObjectIdent -> IO RetrieveResult retrieve srv n i = -	serverRequest srv RetrieveFailure (RetrieveSuccess . Share n) $+	serverRequest srv RetrieveFailure (RetrieveSuccess . Share n) i $ 		getObject i  -- | Servers should automatically obscure, so do nothing.@@ -72,58 +45,8 @@ obscure _ = return ObscureSuccess  count :: Server -> IO CountResult-count srv = serverRequest srv CountFailure id countObjects+count srv = serverRequest srv CountFailure id NoPOWIdent countObjects  -- | Not needed for servers.-move :: Server -> Storage -> IO ()+move :: Server -> Storage -> IO [StoreResult] move _ _ = error "move is not implemented for servers"--serverRequest-	:: Server-	-> (String -> a)-	-> (r -> a)-	-> (Maybe ProofOfWork -> Manager -> BaseUrl -> ExceptT ServantError IO (ProofOfWorkRequirement r))-	-> IO a-serverRequest srv onerr onsuccess a = -	-- A new Manager is allocated for each request, rather than reusing-	-- any connection. This is a feature; it makes correlation attacks-	-- harder because the server can't tell if two connections-	-- (over tor) came from the same user.-	go Nothing =<< torableManager-  where-	url = serverUrl srv-	go pow manager = do-		res <- runExceptT $ a pow manager url-		case res of-			Left err -> return $ onerr $ -				"server failure: " ++ show err-			Right (Result r) -> return $ onsuccess r-			Right needpow -> error "NEEDPOW" -- loop with pow---- | HTTP Manager supporting tor .onion and regular hosts-torableManager :: IO Manager-torableManager = newManager $ defaultManagerSettings-	{ managerRawConnection = return conn-	}-  where-	conn addr host port-		| ".onion" `isSuffixOf` map toLower host = torConnection host port-		| otherwise = do-			regular <- managerRawConnection defaultManagerSettings-			regular addr host port--torConnection :: HostName -> Port -> IO Connection-torConnection onionaddress p = do-	(socket, _) <- socksConnect torsockconf socksaddr-	socketConnection socket 8192-  where-	torsocksport = 9050-	torsockconf = defaultSocksConf "127.0.0.1" torsocksport-	socksdomain = SocksAddrDomainName (BU8.fromString onionaddress)-	socksaddr = SocksAddress socksdomain (fromIntegral p)--socketConnection :: Network.Socket.Socket -> Int -> IO Connection-socketConnection socket chunksize = makeConnection-	(recv socket chunksize)-	(sendAll socket)-	(Network.Socket.close socket)

@@ -1,15 +1,8 @@ Soon: -* Run a key restore and make sure it takes 35 to 50 minutes.-* client/server Proof Of Work * Implement the different categories of servers in the server list.-* Include an example tor hidden service config * Get some keysafe servers set up.-* Keep a local record of keys that have been backed up, and the tunables-  and password entropy. This will allow warning later if the crack estimate-  has to be revised downward for some reason, or if a server is-  compromised.-* Run --uploadqueued periodically (systemd timer?)+* Run --uploadqueued periodically (systemd timer or desktop autostart?)  Later: @@ -25,9 +18,8 @@   and rejects passwords that would cost less than $N to crack at current   rates. This should add a combo box to the password entry form in the   GUI to let the user adjust the $N there.-* --name and --othername to allow specifying those at the command line,-  bypassing the prompts. With these and --key-value, keysafe would only-  prompt for the password.+* Add some random padding to http requests and responses, to make it+  harder for traffic analysis to tell that it's keysafe traffic.  Wishlist: 

@@ -9,6 +9,7 @@  import Cost import qualified Crypto.Argon2 as Argon2+import Data.Word  -- | To determine the tunables used for a key name the expensive hash of the -- name is calculated, using a particular configuration, and if the@@ -139,3 +140,23 @@ knownObjectSizes = map (calc . snd) knownTunings   where 	calc t = objectSize t * shareOverhead t++-- Hash for client-server Proof Of Work. This is tuned to take around+-- 4 seconds to calculate the hash 256 times on a 4 core machine, with +-- 0 added iterations. Adding more iterations will increase that somewhat.+--+-- This is not included in Tunables because it doesn't affect object+-- encryption and storage. Any change to this will break backwards+-- compatability of the HTTP protocol!+proofOfWorkHashTunable :: Word32 -> ExpensiveHashTunable+proofOfWorkHashTunable addits = +	UseArgon2 (CPUCost (Seconds nsecs) (Divisibility 4)) $ +		Argon2.HashOptions+			{ Argon2.hashIterations = nits+			, Argon2.hashMemory = 1000+			, Argon2.hashParallelism = 4+			, Argon2.hashVariant = Argon2.Argon2i+			}+  where+	nits = 20 + addits+	nsecs = (4 * fromIntegral nits / 20) / 256

@@ -61,6 +61,3 @@ -- A gpg keyid is the obvious example. data KeyId = KeyId B.ByteString 	deriving (Show)--data BenchmarkResult t = BenchmarkResult { expectedBenchmark :: t, actualBenchmark :: t }-	deriving (Show)

@@ -13,8 +13,8 @@ 	-- ^ cost in Seconds, using 1 physical CPU core 	deriving (Show, Eq, Ord) -newtype Seconds = Seconds Integer-	deriving (Num, Eq, Ord, Show)+newtype Seconds = Seconds Rational+	deriving (Num, Fractional, Eq, Ord, Show)  -- | How many CPU cores a single run of an operation can be divided amoung. newtype Divisibility = Divisibility Integer

@@ -0,0 +1,16 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.Server where++import Network.Wai.Handler.Warp (Port)++type HostName = String++data Server = Server+	{ serverName :: HostName+	, serverPort :: Port+	}+	deriving (Show)

@@ -9,6 +9,7 @@ module Types.Storage where  import Types+import Types.Server import GHC.Generics import Data.Aeson.Types @@ -31,8 +32,10 @@ 	-- ^ Run after making some calls to storeShare/retrieveShare, 	-- to avoid correlation attacks. 	, countShares :: IO CountResult-	, moveShares :: Storage -> IO ()+	, moveShares :: Storage -> IO [StoreResult] 	-- ^ Tries to move all shares from this storage to another one.+	, uploadQueue :: Maybe Storage+	, getServer :: Maybe Server 	}  data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String

@@ -11,6 +11,7 @@ import Control.Monad import UI.Zenity import UI.Readline+import UI.NonInteractive import Control.Concurrent.MVar  availableUIs :: IO [UI]@@ -27,7 +28,7 @@ 		l <- availableUIs 		case l of 			(u:_) -> return u-			[] -> error "Neither zenity nor the readline UI are available"+			[] -> return noninteractiveUI  -- Adds a percent to whatever amount the progress bar is at. type AddPercent = Percent -> IO ()

@@ -0,0 +1,42 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module UI.NonInteractive (noninteractiveUI) where++import Types.UI+import System.IO+import Control.Exception++noninteractiveUI :: UI+noninteractiveUI = UI+	{ isAvailable = return True+	, showError = myShowError+	, showInfo = myShowInfo+	, promptQuestion = myPrompt+	, promptName = \t d _ -> myPrompt t d+	, promptPassword = \b t d -> myPrompt t d b+	, promptKeyId = myPrompt+	, withProgress = myWithProgress+	}++myShowError :: Desc -> IO ()+myShowError desc = hPutStrLn stderr $ "Error: " ++ desc++myShowInfo :: Title -> Desc -> IO ()+myShowInfo _title desc = putStrLn desc++myPrompt :: Title -> Desc -> x -> IO a+myPrompt _title desc _ = do+	putStrLn desc+	error "Not running at a terminal and zenity is not installed; cannot interact with user."++myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a+myWithProgress _title desc a = bracket_ setup cleanup (a sendpercent)+  where+	setup = putStrLn desc+	sendpercent p = do+		putStr (show p ++ "%  ")+		hFlush stdout+	cleanup = putStrLn "done"

@@ -1,5 +1,5 @@ Name: keysafe-Version: 0.20160831+Version: 0.20160914 Cabal-Version: >= 1.8 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess@@ -60,10 +60,23 @@     , stm == 2.4.*     , socks == 0.5.*     , network == 2.6.*-    -- Temporarily inlined due to https://github.com/ocharles/argon2/issues/3+    , token-bucket == 0.1.*+    , bloomfilter == 2.0.*+    , disk-free-space == 0.1.*+    , lifted-base == 0.2.*+    , unbounded-delays == 0.1.*+    , fast-logger == 2.4.*+    , SafeSemaphore == 0.10.*+    , crypto-random == 0.0.*+    , async == 2.1.*+    -- Temporarily inlined due to FTBFS bug+    -- https://github.com/ocharles/argon2/issues/2     -- argon2 == 1.1.*   Extra-Libraries: argon2   Other-Modules:+    BackupRecord+    Benchmark+    ByteStrings     Crypto.Argon2.FFI     Crypto.Argon2     CmdLine@@ -74,9 +87,13 @@     Gpg     HTTP     HTTP.Client+    HTTP.Logger+    HTTP.ProofOfWork     HTTP.Server+    HTTP.RateLimit     SecretKey     Serialization+    Servers     Share     Storage     Storage.Local@@ -85,10 +102,12 @@     Tunables     Types     Types.Cost+    Types.Server     Types.Storage     Types.UI     UI     UI.Readline+    UI.NonInteractive     UI.Zenity  source-repository head

@@ -13,12 +13,13 @@ import UI import Encryption import Entropy-import ExpensiveHash+import Benchmark import Tests import Cost import SecretKey import Share import Storage+import BackupRecord import HTTP.Server import qualified Gpg import Data.Maybe@@ -53,45 +54,53 @@ 	go mode (CmdLine.secretkeysource cmdline)   where 	go CmdLine.Backup (Just secretkeysource) =-		backup storagelocations ui tunables secretkeysource+		backup cmdline storagelocations ui tunables secretkeysource 			=<< getSecretKey secretkeysource 	go CmdLine.Restore (Just secretkeydest) =-		restore storagelocations ui possibletunables secretkeydest+		restore cmdline storagelocations ui possibletunables secretkeydest 	go CmdLine.Backup Nothing =-		backup storagelocations ui tunables Gpg.anyKey+		backup cmdline storagelocations ui tunables Gpg.anyKey 			=<< Gpg.getKeyToBackup ui 	go CmdLine.Restore Nothing =-		restore storagelocations ui possibletunables Gpg.anyKey-	go CmdLine.UploadQueued _ =-		uploadQueued (CmdLine.localstoragedirectory cmdline)+		restore cmdline storagelocations ui possibletunables Gpg.anyKey+	go CmdLine.UploadQueued _ = do+		problems <- uploadQueued (CmdLine.localstoragedirectory cmdline)+		if null problems+			then return ()+			else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.") 	go (CmdLine.Server) _ = 		runServer 			(CmdLine.localstoragedirectory cmdline)-			(CmdLine.serverAddress $ CmdLine.serverConfig cmdline)-			(CmdLine.serverPort $ CmdLine.serverConfig cmdline)+			(CmdLine.serverConfig cmdline)+	go (CmdLine.Chaff hn) _ = storeChaff hn+		(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+backup :: CmdLine.CmdLine -> StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()+backup cmdline storagelocations ui tunables secretkeysource secretkey = do 	username <- userName-	Name theirname <- fromMaybe (error "Aborting on no username") -		<$> promptName ui "Enter your name"-			usernamedesc (Just username) validateName+	Name theirname <- case CmdLine.name cmdline of+		Just n -> pure n+		Nothing -> fromMaybe (error "Aborting on no username") +			<$> promptName ui "Enter your name"+				usernamedesc (Just username) validateName 	go theirname   where 	go theirname = do 		cores <- fromMaybe 1 <$> getNumCores-		Name othername <- fromMaybe (error "aborting on no othername")-			<$> promptName ui "Enter other name"-				othernamedesc Nothing validateName+		Name othername <- case CmdLine.name cmdline of+			Just n -> pure n+			Nothing -> fromMaybe (error "aborting on no othername")+				<$> promptName ui "Enter other name"+					othernamedesc Nothing validateName 		let name = Name (theirname <> " " <> othername)-		kek <- promptkek name+		(kek, passwordentropy) <- promptpassword name 		let sis = shareIdents tunables name secretkeysource 		let cost = getCreationCost kek <> getCreationCost sis-		r <- withProgressIncremental ui "Encrypting and storing data"+		(r, queued, locs) <- withProgressIncremental ui "Encrypting and storing data" 			(encryptdesc cost cores) $ \addpercent -> do 				let esk = encrypt tunables kek secretkey 				shares <- genShares esk tunables@@ -99,8 +108,13 @@ 				_ <- sis `seq` addpercent 25 				let step = 50 `div` sum (map S.size shares) 				storeShares storagelocations sis shares (addpercent step)+		backuprecord <- mkBackupRecord (mapMaybe getServer locs) secretkeysource passwordentropy 		case r of-			StoreSuccess -> showInfo ui "Success" "Your secret key was successfully encrypted and backed up."+			StoreSuccess -> do+				storeBackupRecord backuprecord+				if queued+					then showInfo ui "Backup queued" "Some data was not sucessfully uploaded to servers, and has been queued for later upload. Run keysafe --uploadqueued at a later point to finish the backup."+					else showInfo ui "Backup success" "Your secret key was successfully encrypted and backed up." 			StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s) 			StoreAlreadyExists -> do 				showError ui $ unlines@@ -108,20 +122,20 @@ 					, "Please try again with a different name." 					] 				go theirname-	promptkek name = do+	promptpassword 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 passwordentropy = calcPasswordEntropy password badwords 		let crackcost = estimateAttackCost spotAWS $-			estimateBruteforceOf kek $-				passwordEntropy password badwords+			estimateBruteforceOf kek passwordentropy 		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+				promptpassword name 			else do 				(thisyear, _, _) <- toGregorian . utctDay 					<$> getCurrentTime@@ -129,8 +143,8 @@ 					(crackdesc crackcost thisyear) 					"Is your password strong enough?" 				if ok-					then return kek-					else promptkek name+					then return (kek, passwordentropy)+					else promptpassword name 	namewords (Name nb) = words (BU8.toString nb) 	keydesc = case secretkeysource of 		GpgKey _ -> "gpg secret key"@@ -184,16 +198,20 @@ 	, "A place you like to visit." 	] -restore :: StorageLocations -> UI -> [Tunables] -> SecretKeySource -> IO ()-restore storagelocations ui possibletunables secretkeydest = do+restore :: CmdLine.CmdLine -> StorageLocations -> UI -> [Tunables] -> SecretKeySource -> IO ()+restore cmdline storagelocations ui possibletunables secretkeydest = do 	cores <- fromMaybe 1 <$> getNumCores 	username <- userName-	Name theirname <- fromMaybe (error "Aborting on no username") -		<$> promptName ui "Enter your name"-			namedesc (Just username) validateName-	Name othername <- fromMaybe (error "aborting on no othername")-		<$> promptName ui "Enter other name"-			othernamedesc Nothing validateName+	Name theirname <- case CmdLine.name cmdline of+		Just n -> pure n+		Nothing -> fromMaybe (error "Aborting on no username") +			<$> promptName ui "Enter your name"+				namedesc (Just username) validateName+	Name othername <- case CmdLine.name cmdline of+		Just n -> pure n+		Nothing -> fromMaybe (error "aborting on no othername")+			<$> promptName ui "Enter other name"+				othernamedesc Nothing validateName 	let name = Name (theirname <> " " <> othername) 	password <- fromMaybe (error "Aborting on no password")  		<$> promptPassword ui True "Enter password" passworddesc@@ -201,7 +219,7 @@ 	let mksis tunables = shareIdents tunables name secretkeydest 	r <- downloadInitialShares storagelocations ui mksis possibletunables 	case r of-		Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name or password?"+		Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name?" 		Just (tunables, shares, sis) -> do 			let candidatekeys = candidateKeyEncryptionKeys tunables name password 			let cost = getCreationCost candidatekeys