module Crypto.SCRAPE
(
Threshold
, ShareId
, ExtraGen(..)
, Point
, DLEQ.Proof
, DLEQ.ParallelProofs
, Scalar
, Secret(..)
, Participants(..)
, PublicKey(..)
, PrivateKey(..)
, KeyPair(..)
, DhSecret(..)
, Escrow(..)
, Commitment(..)
, EncryptedSi(..)
, DecryptedShare(..)
, escrow
, escrowWith
, escrowNew
, shareDecrypt
, verifyEncryptedShares
, verifyDecryptedShare
, verifySecret
, recover
, secretToDhSecret
, reorderDecryptShares
, keyPairGenerate
) where
import Control.DeepSeq
import Control.Monad
import GHC.Generics
import Data.Binary
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
import Foundation (fromList, (<>), Offset(..))
import Foundation.Array
import Foundation.Collection ((!))
newtype Commitment = Commitment { unCommitment :: Point }
deriving (Show,Eq,NFData,Binary)
type Threshold = 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
newtype Si = Si Scalar
newtype EncryptedSi = EncryptedSi Point
deriving (Show,Eq,Generic,NFData,Binary)
data DecryptedShare = DecryptedShare
{ shareDecryptedVal :: !Point
, decryptedValidProof :: !DLEQ.Proof
} deriving (Show,Eq,Generic)
instance NFData DecryptedShare
instance Binary DecryptedShare where
get = DecryptedShare <$> get <*> get
put (DecryptedShare val proof) = put val >> put proof
data Escrow = Escrow
{ escrowExtraGen :: !ExtraGen
, escrowPolynomial :: !Polynomial
, escrowSecret :: !Secret
, escrowProof :: !DLEQ.Proof
} deriving (Show,Eq,Generic)
instance NFData Escrow
newtype Participants = Participants [PublicKey]
deriving (Show,Eq,Generic)
instance NFData Participants
instance Binary Participants
escrowNew :: MonadRandom randomly
=> Threshold
-> randomly Escrow
escrowNew threshold = do
poly <- Polynomial.generate (Polynomial.Degree $ fromIntegral threshold 1)
gen <- pointFromSecret <$> keyGenerate
let secret = Polynomial.atZero poly
gS = pointFromSecret secret
challenge <- keyGenerate
let extraPoint = gen .* secret
dleq = DLEQ.DLEQ { DLEQ.dleq_g1 = curveGenerator, DLEQ.dleq_h1 = gS, DLEQ.dleq_g2 = gen, DLEQ.dleq_h2 = extraPoint }
proof = DLEQ.generate challenge secret dleq
return $ Escrow
{ escrowExtraGen = ExtraGen gen
, escrowPolynomial = poly
, escrowSecret = Secret gS
, escrowProof = proof
}
escrow :: MonadRandom randomly
=> Threshold
-> Participants
-> randomly (ExtraGen,
Secret,
[EncryptedSi],
[Commitment],
DLEQ.Proof,
DLEQ.ParallelProofs)
escrow t pubs@(Participants nlist)
| t < 1 = error "cannot create SCRAPE with threshold < 1"
| t >= fromIntegral n = error "cannot create SCRAPE with threshold equal/above number of participants"
| otherwise = do
e <- escrowNew t
(eshares, commitments, proofs) <- escrowWith e pubs
return (escrowExtraGen e, escrowSecret e, eshares, commitments, escrowProof e, proofs)
where n = length nlist
escrowWith :: MonadRandom randomly
=> Escrow
-> Participants
-> randomly ([EncryptedSi], [Commitment], DLEQ.ParallelProofs)
escrowWith escrowParams (Participants pubs) = do
ws <- replicateM n keyGenerate
let sis = map (Si . Polynomial.evaluate (escrowPolynomial escrowParams) . keyFromNum) indexes
esis = map (uncurry encryptSi) $ zip pubs sis
vis = map makeVi sis
proofParams = zipWith6 makeParallelProofParam indexes pubs vis sis esis ws
parallelProofs = DLEQ.generateParallel proofParams
return (esis, vis, parallelProofs)
where
indexes :: [Integer]
indexes = [1..fromIntegral n]
n = length pubs
ExtraGen g = escrowExtraGen escrowParams
makeVi (Si s) = Commitment (g .* s)
encryptSi (PublicKey p) (Si s) = EncryptedSi (p .* s)
makeParallelProofParam _ (PublicKey pub) (Commitment vi) (Si si) (EncryptedSi esi) w =
let dleq = DLEQ.DLEQ { DLEQ.dleq_g1 = g, DLEQ.dleq_h1 = vi, DLEQ.dleq_g2 = pub, DLEQ.dleq_h2 = esi }
in (w, si, dleq)
zipWith6 f (u1:us) (v1:vs) (w1:ws) (x1:xs) (y1:ys) (z1:zs) = f u1 v1 w1 x1 y1 z1 : zipWith6 f us vs ws xs ys zs
zipWith6 _ [] [] [] [] [] [] = []
zipWith6 _ _ _ _ _ _ _ = error "zipWith6: internal error should have same length"
shareDecrypt :: MonadRandom randomly
=> KeyPair
-> EncryptedSi
-> randomly DecryptedShare
shareDecrypt (KeyPair (PrivateKey xi) (PublicKey yi)) (EncryptedSi _Yi) = do
challenge <- keyGenerate
let dleq = DLEQ.DLEQ curveGenerator yi si _Yi
proof = DLEQ.generate challenge xi dleq
return $ DecryptedShare si proof
where xiInv = keyInverse xi
si = _Yi .* xiInv
verifyEncryptedShares :: MonadRandom randomly
=> ExtraGen
-> Threshold
-> [Commitment]
-> DLEQ.ParallelProofs
-> [EncryptedSi]
-> Participants
-> randomly Bool
verifyEncryptedShares (ExtraGen g) t commitments proofs encryptedShares (Participants pubs) = do
if DLEQ.verifyParallel dleqs proofs
then rdCheck
else return False
where
!n = fromIntegral $ length pubs
indexes = [1..n]
dleqs = zipWith3 makeDLEQ commitments pubs encryptedShares
makeDLEQ (Commitment vi) (PublicKey pki) (EncryptedSi esi) =
DLEQ.DLEQ g vi pki esi
rdCheck = do
poly <- Polynomial.generate (Polynomial.Degree $ fromIntegral $ n t 1)
let cPerp = for indexes $ \evalPoint ->
vi evalPoint #* Polynomial.evaluate poly (keyFromNum evalPoint)
let v = mulAndSum $ zipWith (\(Commitment c) cip -> (c,cip)) commitments cPerp
return $ v == pointIdentity
where
for = flip map
vi i = foldl1 (#*)
$ for ((\j -> j /= i) `filter` indexes) $ \j -> keyInverse (keyFromNum i #- keyFromNum j)
verifyDecryptedShare :: (EncryptedSi, PublicKey, DecryptedShare)
-> Bool
verifyDecryptedShare (EncryptedSi eshare,PublicKey pub,share) =
DLEQ.verify dleq (decryptedValidProof share)
where dleq = DLEQ.DLEQ curveGenerator pub (shareDecryptedVal share) eshare
verifySecret :: ExtraGen
-> Threshold
-> [Commitment]
-> Secret
-> DLEQ.Proof
-> Bool
verifySecret (ExtraGen gen) t 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 = commitmentInterpolate
}
t' = fromIntegral t
indices = take t' $ map keyFromNum [1..]
commitmentInterpolate =
foldl' (.+) pointIdentity $ map (uncurry lagrangeBasis)
$ zip [1..] (take t' commitments)
lagrangeBasis idx (Commitment x) =
x .* (Polynomial.lambda (fromList indices) (Offset $ idx 1))
reorderDecryptShares :: Participants
-> [(PublicKey, DecryptedShare)]
-> Maybe [(ShareId, DecryptedShare)]
reorderDecryptShares (Participants participants) shares =
sequence $ map indexSharesByParticipants shares
where
idxParticipants = zip participants [1..]
indexSharesByParticipants (pub, dshare) =
case lookup pub idxParticipants of
Nothing -> Nothing
Just i -> Just (i, dshare)
recover :: [(ShareId, DecryptedShare)]
-> Secret
recover shares = Secret $ foldl' (.+) pointIdentity $ map interpolate (zip shares [0..])
where
t = fromIntegral $ length shares
aShares = fromList shares
interpolate :: ((Integer, DecryptedShare), ShareId) -> Point
interpolate (share, sid) = shareDecryptedVal (snd share) .* calc 0 (keyFromNum 1)
where
!si = keyFromNum $ fst (aShares `unsafeIndex` fromIntegral sid)
calc :: Integer -> Scalar -> Scalar
calc !j !acc
| j == t = acc
| j == sid = calc (j+1) acc
| otherwise =
let sj = keyFromNum $ fst (aShares `unsafeIndex` fromIntegral j)
e = sj #* keyInverse (sj #- si)
in calc (j+1) (acc #* e)
unsafeIndex :: Array a -> Int -> a
unsafeIndex v i = maybe (error $ "accessing index : " <> show i <> " out of bound") id $ (v ! Offset i)