module Crypto.PVSS
(
Threshold
, ShareId
, ExtraGen
, Point
, DLEQ.Proof
, Scalar
, Secret
, PublicKey(..)
, PrivateKey(..)
, KeyPair(..)
, DhSecret(..)
, Escrow(..)
, Commitment
, EncryptedShare(..)
, DecryptedShare(..)
, escrow
, escrowWith
, escrowNew
, createCommitments
, sharesCreate
, shareCreate
, shareDecrypt
, verifyEncryptedShare
, verifyDecryptedShare
, verifySecret
, getValidRecoveryShares
, recover
, secretToDhSecret
, keyPairGenerate
) where
import Control.DeepSeq
import Control.Monad
import GHC.Generics
import Data.Binary
import Data.Binary.Get (getWord32le)
import Data.Binary.Put (putWord32le)
import Data.List (foldl')
import qualified Crypto.PVSS.DLEQ as DLEQ
import Crypto.PVSS.ECC
import Crypto.PVSS.Polynomial (Polynomial (..))
import qualified Crypto.PVSS.Polynomial as Polynomial
import Crypto.Random
newtype Commitment = Commitment { unCommitment :: Point }
deriving (Show,Eq,NFData,Binary)
type Threshold = Integer
type Participants = Integer
type ShareId = Integer
newtype ExtraGen = ExtraGen Point
deriving (Show,Eq,NFData,Binary)
newtype Secret = Secret Point
deriving (Show,Eq,NFData,Binary)
secretToDhSecret :: Secret -> DhSecret
secretToDhSecret (Secret p) = pointToDhSecret p
data EncryptedShare = EncryptedShare
{ shareID :: !ShareId
, shareEncryptedVal :: !Point
, shareValidProof :: !DLEQ.Proof
} deriving (Show,Eq,Generic)
instance NFData EncryptedShare
instance Binary EncryptedShare where
get = EncryptedShare <$> (fromIntegral <$> getWord32le) <*> get <*> get
put (EncryptedShare sid val proof) = putWord32le (fromIntegral sid) >> put val >> put proof
data DecryptedShare = DecryptedShare
{ decryptedShareID :: !ShareId
, shareDecryptedVal :: !Point
, decryptedValidProof :: !DLEQ.Proof
} deriving (Show,Eq,Generic)
instance NFData DecryptedShare
instance Binary DecryptedShare where
get = DecryptedShare <$> (fromIntegral <$> getWord32le) <*> get <*> get
put (DecryptedShare sid val proof) = putWord32le (fromIntegral sid) >> put val >> put proof
data Escrow = Escrow
{ escrowExtraGen :: !ExtraGen
, escrowPolynomial :: !Polynomial
, escrowSecret :: !Secret
, escrowProof :: !DLEQ.Proof
} deriving (Show,Eq,Generic)
instance NFData Escrow
escrowNew :: MonadRandom randomly
=> Threshold
-> randomly Escrow
escrowNew threshold = do
poly <- Polynomial.generate (fromIntegral threshold)
gen <- pointFromSecret <$> keyGenerate
let secret = Polynomial.atZero poly
gS = pointFromSecret secret
challenge <- keyGenerate
let dleq = DLEQ.DLEQ { DLEQ.dleq_g1 = curveGenerator, DLEQ.dleq_h1 = gS, DLEQ.dleq_g2 = gen, DLEQ.dleq_h2 = gen .* secret }
proof = DLEQ.generate challenge secret dleq
return $ Escrow
{ escrowExtraGen = ExtraGen gen
, escrowPolynomial = poly
, escrowSecret = Secret gS
, escrowProof = proof
}
escrow :: MonadRandom randomly
=> Threshold
-> [PublicKey]
-> randomly (ExtraGen, Secret, DLEQ.Proof, [Commitment], [EncryptedShare])
escrow t pubs = do
e <- escrowNew t
(commitments, eshares) <- escrowWith e pubs
return (escrowExtraGen e, escrowSecret e, escrowProof e, commitments, eshares)
escrowWith :: MonadRandom randomly
=> Escrow
-> [PublicKey]
-> randomly ([Commitment], [EncryptedShare])
escrowWith escrow pubs = do
let commitments = createCommitments escrow
encryptedShares <- sharesCreate escrow commitments pubs
return (commitments, encryptedShares)
createCommitments :: Escrow -> [Commitment]
createCommitments escrow =
map (\c -> Commitment (g .* c)) polyCoeffs
where
Polynomial polyCoeffs = escrowPolynomial escrow
ExtraGen g = escrowExtraGen escrow
sharesCreate :: MonadRandom randomly
=> Escrow
-> [Commitment]
-> [PublicKey]
-> randomly [EncryptedShare]
sharesCreate escrow commitments pubs = forM (zip [1..] pubs) $ uncurry (shareCreate escrow commitments)
shareCreate :: MonadRandom randomly
=> Escrow
-> [Commitment]
-> ShareId
-> PublicKey
-> randomly EncryptedShare
shareCreate e commitments shareId (PublicKey pub) = do
let pEvaled_i = Polynomial.evaluate poly (keyFromNum $ shareId)
yi = pub .* pEvaled_i
xi = g .* pEvaled_i
challenge <- keyGenerate
let dleq = DLEQ.DLEQ { DLEQ.dleq_g1 = g, DLEQ.dleq_h1 = xi, DLEQ.dleq_g2 = pub, DLEQ.dleq_h2 = yi }
proof = DLEQ.generate challenge pEvaled_i dleq
return $ EncryptedShare shareId yi proof
where
ExtraGen g = escrowExtraGen e
poly = escrowPolynomial e
shareDecrypt :: MonadRandom randomly
=> KeyPair
-> EncryptedShare
-> randomly DecryptedShare
shareDecrypt (KeyPair (PrivateKey xi) (PublicKey yi)) (EncryptedShare sid _Yi _) = do
challenge <- keyGenerate
let dleq = DLEQ.DLEQ curveGenerator yi si _Yi
proof = DLEQ.generate challenge xi dleq
return $ DecryptedShare sid si proof
where xiInv = keyInverse xi
si = _Yi .* xiInv
verifyEncryptedShare :: ExtraGen
-> [Commitment]
-> (EncryptedShare, PublicKey)
-> Bool
verifyEncryptedShare (ExtraGen g) commitments (share,PublicKey pub) =
DLEQ.verify dleq (shareValidProof share)
where dleq = DLEQ.DLEQ
{ DLEQ.dleq_g1 = g
, DLEQ.dleq_h1 = xi
, DLEQ.dleq_g2 = pub
, DLEQ.dleq_h2 = shareEncryptedVal share
}
xi = createXi (fromIntegral $ shareID share) commitments
verifyDecryptedShare :: (EncryptedShare, PublicKey, DecryptedShare)
-> Bool
verifyDecryptedShare (eshare,PublicKey pub,share) =
DLEQ.verify dleq (decryptedValidProof share)
where dleq = DLEQ.DLEQ curveGenerator pub (shareDecryptedVal share) (shareEncryptedVal eshare)
verifySecret :: ExtraGen
-> [Commitment]
-> Secret
-> DLEQ.Proof
-> Bool
verifySecret (ExtraGen gen) commitments (Secret secret) proof =
DLEQ.verify dleq proof
where dleq = DLEQ.DLEQ
{ DLEQ.dleq_g1 = curveGenerator
, DLEQ.dleq_h1 = secret
, DLEQ.dleq_g2 = gen
, DLEQ.dleq_h2 = unCommitment (commitments !! 0)
}
recover :: [DecryptedShare]
-> Secret
recover shares =
Secret $ foldl' interpolate pointIdentity (zip shares [0..])
where
t = fromIntegral $ length shares
interpolate :: Point -> (DecryptedShare, ShareId) -> Point
interpolate !result (share, sid) = result .+ (shareDecryptedVal share .* value)
where
value = calc 0 (keyFromNum 1)
calc :: Integer -> Scalar -> Scalar
calc !j acc
| j == t = acc
| j == sid = calc (j+1) acc
| otherwise =
let sj = decryptedShareID (shares !! fromIntegral j)
si = decryptedShareID (shares !! fromIntegral sid)
dinv = keyInverse (keyFromNum sj #- keyFromNum si)
e = keyFromNum sj #* dinv
in calc (j+1) (acc #* e)
getValidRecoveryShares :: Threshold
-> [(EncryptedShare, PublicKey, DecryptedShare)]
-> [DecryptedShare]
getValidRecoveryShares threshold shares =
map thd . take (fromIntegral threshold) . filter verifyDecryptedShare $ shares
where thd (_,_,ds) = ds
createXi :: ShareId
-> [Commitment]
-> Point
createXi i commitments =
mulPowerAndSum (map unCommitment commitments) (fromIntegral i)