more cost calculation and refactored Tunables

9 files changed, 383 insertions, 51 deletions

diff --git a/.gitignore b/.gitignore
index a261f29..0ff70cb 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,3 @@
 dist/*
+*.o
+*.hi
diff --git a/Cost.hs b/Cost.hs
new file mode 100644
index 0000000..0425707
--- /dev/null
+++ b/Cost.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Cost where
+
+import Utility.HumanTime
+import Data.Monoid
+
+-- | An estimated cost to perform an operation.
+data Cost op = CPUCost Seconds | GPUCost Seconds | CombinedCost (Cost op) (Cost op)
+	deriving (Show)
+
+newtype Seconds = Seconds Integer
+	deriving (Num)
+
+instance Show Seconds where
+	show (Seconds n) = fromDuration (Duration n)
+
+-- | Cost in seconds, with the type of hardware needed.
+totalCost :: Cost op -> (Seconds, [UsingHardware])
+totalCost (CPUCost s) = (s, [UsingCPU])
+totalCost (GPUCost s) = (s, [UsingGPU])
+totalCost (CombinedCost a b) = 
+	let (s1, h1) = totalCost a
+	    (s2, h2) = totalCost b
+	in (s1+s2, h1++h2)
+
+data UsingHardware = UsingCPU | UsingGPU | UsingASIC
+	deriving (Show)
+
+raiseCostPower :: Cost c -> Entropy e -> Cost c
+raiseCostPower c (Entropy e) = adjustCost c (* 2^e)
+
+adjustCost :: Cost c -> (Seconds -> Seconds) -> Cost c
+adjustCost (CPUCost s) f = CPUCost (f s)
+adjustCost (GPUCost s) f = GPUCost (f s)
+adjustCost (CombinedCost a b) f = CombinedCost (adjustCost a f) (adjustCost b f)
+
+castCost :: Cost a -> Cost b
+castCost (CPUCost s) = CPUCost s
+castCost (GPUCost s) = GPUCost s
+castCost (CombinedCost a b) = CombinedCost (castCost a) (castCost b)
+
+instance Monoid (Cost t) where
+	mempty = CPUCost (Seconds 0)
+	CPUCost (Seconds a) `mappend` CPUCost (Seconds b) =
+		CPUCost (Seconds (a+b))
+	GPUCost (Seconds a) `mappend` GPUCost (Seconds b) =
+		GPUCost (Seconds (a+b))
+	a `mappend` b = CombinedCost a b
+
+-- | Operations whose cost can be measured.
+data DecryptionOp
+data CreationOp
+data BruteForceOp
+
+-- | Calculation of a cost that depends on some amount of entropy.
+type CostCalc op t = Entropy t -> Cost op
+
+-- | Number of bits of entropy
+newtype Entropy t = Entropy Int
+
+-- | Entropy can never go negative when subtracting bits from it.
+reduceEntropy :: Entropy t -> Int -> Entropy t
+reduceEntropy (Entropy a) b = Entropy (max 0 (a - b))
+
+-- | Things that can have entropy
+data UnknownPassword
+
+-- | CostCalc for a brute force linear search through an entropy space
+-- in which each step entails paying a cost.
+--
+-- On average, the solution will be found half way through.
+-- This is equivilant to one bit less of entropy.
+bruteForceLinearSearch :: Cost step -> CostCalc BruteForceOp t
+bruteForceLinearSearch stepcost e = 
+	castCost stepcost `raiseCostPower` reduceEntropy e 1
diff --git a/Encryption.hs b/Encryption.hs
index 083aedd..98afdfd 100644
--- a/Encryption.hs
+++ b/Encryption.hs
@@ -3,23 +3,37 @@
 module Encryption where
 
 import Types
+import Cost
+import Tunables
 import ExpensiveHash
 import qualified Data.ByteString as B
 import Raaz.Core.Encode
 import qualified Raaz.Cipher.AES as AES
 import Data.Word
+import Data.Monoid
 
 -- | An AES key, which is used to encrypt the key that is stored
 -- in keysafe.
-newtype KeyEncryptionKey = KeyEncryptionKey AES.KEY256
+data KeyEncryptionKey = KeyEncryptionKey
+	AES.KEY256
+	(Cost DecryptionOp) 
+	(CostCalc BruteForceOp UnknownPassword)
 
--- | An ExpensiveHash of the KeyIdent and a RandomObstacle are combined
--- to form the AES key.
---
--- An attacker has to brute force both, while a legitimate user
--- only has to brute force the RandomObstacle.
-genKeyEncryptionKey :: KeyIdent -> Password -> KeyEncryptionKey
-genKeyEncryptionKey = undefined
+-- | The ExpensiveHash of the Password is combined with a 
+-- RandomObstacle to form the AES key. Combination method is logical OR.
+genKeyEncryptionKey :: Tunables -> KeyIdent -> Password -> KeyEncryptionKey
+genKeyEncryptionKey tunables keyident password =
+	KeyEncryptionKey k decryptcost bruteforcecalc
+  where
+	k = undefined -- hashb <> ob -- TODO use logical OR
+	(ExpensiveHash hashcost hashb) = expensiveHash tunables salt password
+	salt = Salt keyident
+	(RandomObstacle ob) = genRandomObstacle decryptcost
+	decryptcost = CombinedCost (decryptionCost tunables) (castCost hashcost)
+	-- To brute force data encrypted with this key,
+	-- an attacker needs to pay the decryptcost for each password
+	-- checked.
+	bruteforcecalc = bruteForceLinearSearch decryptcost
 
 -- | A random value which adds difficulty to decrypting, since it's never
 -- written down anywhere and must always be brute-forced.
@@ -32,7 +46,13 @@ genKeyEncryptionKey = undefined
 --
 -- The fewer leading 0's and thus longer the random bits,
 -- the harder it is.
-data RandomObstacle = RandomObstacle Word64
+data RandomObstacle = RandomObstacle B.ByteString
 
-genRandomObstacle :: Int -> RandomObstacle
-genRandomObstacle difficulty = undefined
+-- | Generate a random obstacle that will add the specified cost to AES
+-- decryption.
+--
+-- AES can be calculated more efficiently by a GPU, so the cost must be
+-- a GPU cost.
+genRandomObstacle :: Cost DecryptionOp -> RandomObstacle
+genRandomObstacle (GPUCost c) = undefined
+genRandomObstacle _ = error "decryptionCost must be a GPUCost"
diff --git a/ExpensiveHash.hs b/ExpensiveHash.hs
index 8bfe004..ca357bc 100644
--- a/ExpensiveHash.hs
+++ b/ExpensiveHash.hs
@@ -3,6 +3,8 @@
 module ExpensiveHash where
 
 import Types
+import Cost
+import Tunables
 import qualified Data.ByteString as B
 import Raaz.Core.Encode
 import qualified Crypto.Argon2 as Argon2
@@ -14,41 +16,26 @@ import Control.DeepSeq
 -- This is a lynchpin of keysafe's security, because using this hash
 -- as an encryption key forces brute force attackers to generate
 -- hashes over and over again, taking a very long time.
-data ExpensiveHash = ExpensiveHash Cost B.ByteString
+data ExpensiveHash = ExpensiveHash (Cost CreationOp) B.ByteString
 	deriving (Show)
 
 data Salt t = Salt t
 
-expensiveHash :: Encodable t => RunMode -> Salt t -> Password -> ExpensiveHash
-expensiveHash runmode (Salt s) (Password password) = 
-	ExpensiveHash cost $ Argon2.hash o password (toByteString s)
-  where
-	HashParams o cost = hashParams runmode
+expensiveHash :: Encodable t => Tunables -> Salt t -> Password -> ExpensiveHash
+expensiveHash tunables (Salt s) (Password password) = 
+	ExpensiveHash (argonCost tunables) $
+		Argon2.hash (argonOptions tunables) password (toByteString s)
 
-data HashParams = HashParams Argon2.HashOptions Cost
-
-hashParams :: RunMode -> HashParams
-hashParams SecureMode = HashParams o cost
-  where
-	-- argon2 is GPU and ASIC resistent, so it uses CPU time.
-	-- The selected HashOptions were benchmarked at 661 seconds CPU time
-	-- on a 2 core Intel(R) Core(TM) i5-4210Y CPU @ 1.50GHz.
-	cost = CPUCost (Seconds 600)
-	o = Argon2.HashOptions
-		{ Argon2.hashIterations = 10000
-		, Argon2.hashMemory = 131072 -- 128 mebibtyes per thread
-		, Argon2.hashParallelism = 4 -- 4 threads
-		, Argon2.hashVariant = Argon2.Argon2i
-		}
-hashParams TestingMode =
-	HashParams Argon2.defaultHashOptions $ CPUCost (Seconds 0)
-
-benchmarkExpensiveHash :: IO (Benchmark Cost)
-benchmarkExpensiveHash = do
+benchmarkExpensiveHash :: Tunables -> IO (Benchmark (Cost CreationOp))
+benchmarkExpensiveHash tunables = do
 	start <- getCurrentTime
-	let ExpensiveHash expected b = expensiveHash SecureMode
+	let ExpensiveHash expected b = expensiveHash tunables
 		(Salt (KeyIdent gpgKey (Name ("benchmark" :: B.ByteString))))
 		(Password ("himom" :: B.ByteString))
 	end <- b `deepseq` getCurrentTime
-	let actual = (CPUCost $ Seconds $ end `diffUTCTime` start)
-	return $ Benchmark { expectedBenchmark = expected, actualBenchmark = actual }
+	let diff = floor $ end `diffUTCTime` start
+	let actual = CPUCost $ Seconds diff
+	return $ Benchmark
+		{ expectedBenchmark = expected
+		, actualBenchmark = actual
+		}
diff --git a/Tunables.hs b/Tunables.hs
new file mode 100644
index 0000000..5c39a2d
--- /dev/null
+++ b/Tunables.hs
@@ -0,0 +1,41 @@
+module Tunables where
+
+import Types
+import Cost
+import qualified Crypto.Argon2 as Argon2
+
+data Tunables = Tunables
+	{ argonOptions :: Argon2.HashOptions
+	, argonCost :: Cost CreationOp
+	-- ^ should correspond to the argonOptions
+	, decryptionCost :: Cost DecryptionOp
+	-- ^ controls the decryption cost
+	}
+
+defaultTunables :: Tunables
+defaultTunables = Tunables
+	{ argonOptions = Argon2.HashOptions
+		{ Argon2.hashIterations = 10000
+		, Argon2.hashMemory = 131072 -- 128 mebibtyes per thread
+		, Argon2.hashParallelism = 4 -- 4 threads
+		, Argon2.hashVariant = Argon2.Argon2i
+		}
+	-- argon2 is GPU and ASIC resistent, so it uses CPU time.
+	-- The above HashOptions were benchmarked at 661 seconds CPU time
+	-- on a 2 core Intel(R) Core(TM) i5-4210Y CPU @ 1.50GHz.
+	, argonCost = CPUCost (Seconds 600)
+	-- AES can be calculated more efficiently by a GPU, so this
+	-- cost is a GPU cost.
+	-- This is set to only 1 minute because GPUs are quite a lot
+	-- faster than CPUs at AES, and so setting it higher would make
+	-- clients too slow at key recovery.
+	, decryptionCost = GPUCost (Seconds 60)
+	}
+
+-- | Dials back cryptographic difficulty, not for production use.
+testModeTunables :: Tunables
+testModeTunables = Tunables
+	{ argonOptions = Argon2.defaultHashOptions
+	, argonCost = CPUCost (Seconds 0)
+	, decryptionCost = GPUCost (Seconds 0)
+	}
diff --git a/Types.hs b/Types.hs
index 2be82a8..3b5d39f 100644
--- a/Types.hs
+++ b/Types.hs
@@ -63,16 +63,5 @@ instance Encodable ObjectIdent where
 				n <- readMaybe (B8.unpack ns)
 				return $ ObjectIdent (ShardNum n) keyident
 
--- | An estimated cost to perform an operation.
-data Cost = CPUCost Seconds | GPUCost Seconds
-	deriving (Show)
-
-newtype Seconds = Seconds NominalDiffTime
-	deriving (Show)
-
 data Benchmark t = Benchmark { expectedBenchmark :: t, actualBenchmark :: t }
 	deriving (Show)
-
--- | In testing mode, the cryptographic difficulty is dialed back.
-data RunMode = SecureMode | TestingMode
-	deriving (Show)
diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
new file mode 100644
index 0000000..fe7cf22
--- /dev/null
+++ b/Utility/HumanTime.hs
@@ -0,0 +1,102 @@
+{- Time for humans.
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.HumanTime (
+	Duration(..),
+	durationSince,
+	durationToPOSIXTime,
+	durationToDays,
+	daysToDuration,
+	parseDuration,
+	fromDuration,
+	prop_duration_roundtrips
+) where
+
+import Utility.PartialPrelude
+import Utility.QuickCheck
+
+import qualified Data.Map as M
+import Data.Time.Clock
+import Data.Time.Clock.POSIX (POSIXTime)
+import Data.Char
+import Control.Applicative
+import Prelude
+
+newtype Duration = Duration { durationSeconds :: Integer }
+	deriving (Eq, Ord, Read, Show)
+
+durationSince :: UTCTime -> IO Duration
+durationSince pasttime = do
+	now <- getCurrentTime
+	return $ Duration $ round $ diffUTCTime now pasttime
+
+durationToPOSIXTime :: Duration -> POSIXTime
+durationToPOSIXTime = fromIntegral . durationSeconds
+
+durationToDays :: Duration -> Integer
+durationToDays d = durationSeconds d `div` dsecs
+
+daysToDuration :: Integer -> Duration
+daysToDuration i = Duration $ i * dsecs
+
+{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
+parseDuration :: Monad m => String -> m Duration
+parseDuration = maybe parsefail (return . Duration) . go 0
+  where
+	go n [] = return n
+	go n s = do
+		num <- readish s :: Maybe Integer
+		case dropWhile isDigit s of
+			(c:rest) -> do
+				u <- M.lookup c unitmap
+				go (n + num * u) rest
+			_ -> return $ n + num
+	parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\""
+
+fromDuration :: Duration -> String
+fromDuration Duration { durationSeconds = d }
+	| d == 0 = "0s"
+	| otherwise = concatMap showunit $ go [] units d
+  where
+	showunit (u, n)
+		| n > 0 = show n ++ [u]
+		| otherwise = ""
+	go c [] _ = reverse c
+	go c ((u, n):us) v =
+		let (q,r) = v `quotRem` n
+		in go ((u, q):c) us r
+
+units :: [(Char, Integer)]
+units = 
+	[ ('y', ysecs)
+	, ('d', dsecs)
+	, ('h', hsecs)
+	, ('m', msecs)
+	, ('s', 1)
+	]
+
+unitmap :: M.Map Char Integer
+unitmap = M.fromList units
+
+ysecs :: Integer
+ysecs = dsecs * 365
+
+dsecs :: Integer
+dsecs = hsecs * 24
+
+hsecs :: Integer
+hsecs = msecs * 60
+
+msecs :: Integer
+msecs = 60
+
+-- Durations cannot be negative.
+instance Arbitrary Duration where
+	arbitrary = Duration <$> nonNegative arbitrary
+
+prop_duration_roundtrips :: Duration -> Bool
+prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d
diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
new file mode 100644
index 0000000..5579556
--- /dev/null
+++ b/Utility/PartialPrelude.hs
@@ -0,0 +1,70 @@
+{- Parts of the Prelude are partial functions, which are a common source of
+ - bugs.
+ -
+ - This exports functions that conflict with the prelude, which avoids
+ - them being accidentially used.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.PartialPrelude where
+
+import qualified Data.Maybe
+
+{- read should be avoided, as it throws an error
+ - Instead, use: readish -}
+read :: Read a => String -> a
+read = Prelude.read
+
+{- head is a partial function; head [] is an error
+ - Instead, use: take 1 or headMaybe -}
+head :: [a] -> a
+head = Prelude.head
+
+{- tail is also partial
+ - Instead, use: drop 1 -}
+tail :: [a] -> [a]
+tail = Prelude.tail
+
+{- init too
+ - Instead, use: beginning -}
+init :: [a] -> [a]
+init = Prelude.init
+
+{- last too
+ - Instead, use: end or lastMaybe -}
+last :: [a] -> a
+last = Prelude.last
+
+{- Attempts to read a value from a String.
+ -
+ - Ignores leading/trailing whitespace, and throws away any trailing
+ - text after the part that can be read.
+ -
+ - readMaybe is available in Text.Read in new versions of GHC,
+ - but that one requires the entire string to be consumed.
+ -}
+readish :: Read a => String -> Maybe a
+readish s = case reads s of
+	((x,_):_) -> Just x
+	_ -> Nothing
+
+{- Like head but Nothing on empty list. -}
+headMaybe :: [a] -> Maybe a
+headMaybe = Data.Maybe.listToMaybe
+
+{- Like last but Nothing on empty list. -}
+lastMaybe :: [a] -> Maybe a
+lastMaybe [] = Nothing
+lastMaybe v = Just $ Prelude.last v
+
+{- All but the last element of a list.
+ - (Like init, but no error on an empty list.) -}
+beginning :: [a] -> [a]
+beginning [] = []
+beginning l = Prelude.init l
+
+{- Like last, but no error on an empty list. -}
+end :: [a] -> [a]
+end [] = []
+end l = [Prelude.last l]
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 0000000..4978d42
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -0,0 +1,45 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+	( module X
+	, module Utility.QuickCheck
+	) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import Control.Applicative
+import Prelude
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)