diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016 IOHK +Copyright (c) 2016-2017 IOHK Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# pvss-haskell + +[![Build Status](https://travis-ci.org/input-output-hk/pvss-haskell.svg?branch=master)](https://travis-ci.org/input-output-hk/pvss-haskell) + +Two Haskell implementations of the Public Verifiable Secret Scheme based on: +1) Paper by Berry Schoenmakers (http://www.win.tue.nl/~berry/papers/crypto99.pdf) +2) SCRAPE: Paper by Ignacio Cascudo and Bernardo David (https://eprint.iacr.org/2017/216.pdf) + +## LICENSE + +See [LICENSE](LICENSE) file in this repository. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,60 +1,152 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Main where import System.Environment import Control.Monad +import Control.Exception import Control.DeepSeq -import Crypto.Random import qualified Crypto.PVSS as PVSS -import Data.Hourglass +import qualified Crypto.SCRAPE as SCRAPE +import Data.List import Time.Types import Time.System +import Data.Hourglass (timeDiffP) +import Text.Printf (printf) +#ifdef VERSION_mcl +import qualified Crypto.SCRAPE.BDS as SCRAPE_BDS +import qualified Data.Vector as V +#endif + +showTimeDiff :: (Seconds, NanoSeconds) -> String +showTimeDiff (Seconds s, NanoSeconds n) = + if s > 10 + then printf "%d.%03d seconds" s (n `div` 1000000) + else printf "%d.%06d seconds" s (n `div` 1000) + +timing :: NFData t => IO t -> IO (t, (Seconds, NanoSeconds)) timing f = do t1 <- timeCurrentP a <- f t2 <- a `deepseq` timeCurrentP return (a, t2 `timeDiffP` t1) +timingP :: NFData b => String -> IO b -> IO b timingP n f = do - (a, t) <- timing f - putStrLn (n ++ ": " ++ show t) + (!a, t) <- timing f + putStrLn (n ++ ": " ++ showTimeDiff t) return a +timingPureP :: NFData b => String -> b -> IO b +timingPureP n f = do + t1 <- timeCurrentP + !a <- evaluate f + t2 <- a `deepseq` timeCurrentP + putStrLn (n ++ ": " ++ showTimeDiff (t2 `timeDiffP` t1)) + return a + +chunk :: Int -> [t] -> [[t]] chunk _ [] = [] chunk n l = let (l1,l2) = splitAt n l in l1 : chunk n l2 +go :: PVSS.Threshold -> Int -> IO () go t n = do participants <- replicateM n $ PVSS.keyPairGenerate - !e <- timingP "escrow-new" $ PVSS.escrowNew t + (e, commitments, eshares) <- + timingP "escrow" $ do + !xe <- {-timingP "escrow-new" $-} PVSS.escrowNew t - !commitments <- timingP "commitments" $ return $ PVSS.createCommitments e + !xcommitments <- {-timingP "commitments" $-} return $ PVSS.createCommitments xe - !esharesChunks <- timingP "shares" $ forM (chunk 200 $ zip [1..] (map PVSS.toPublicKey participants)) $ \c -> - timingP ("chunk-" ++ show (fst $ head c)) $ forM c $ uncurry (PVSS.shareCreate e commitments) - let eshares = mconcat esharesChunks + !xesharesChunks <- {-timingP "shares" $-} forM (chunk 200 $ zip [1..] (map PVSS.toPublicKey participants)) $ \c -> + {-timingP (" chunk-" ++ show (fst $ head c)) $ -}forM c $ uncurry (PVSS.shareCreate xe xcommitments) + let eshares = mconcat xesharesChunks + return (xe, xcommitments, eshares) - validated <- timingP "validating" $ forM (chunk 200 $ zip eshares (map PVSS.toPublicKey participants)) $ \c -> - timingP ("vchunk") $ forM c $ return . PVSS.verifyEncryptedShare (PVSS.escrowExtraGen e) commitments + !validated <- timingP "validating" $ forM (chunk 200 $ zip eshares (map PVSS.toPublicKey participants)) $ \c -> + {-timingP (" vchunk") $ -} forM c $ return . PVSS.verifyEncryptedShare (PVSS.escrowExtraGen e) commitments + putStrLn (show $ and $ concat validated) !decryptedShares <- timingP "decrypting" $ mapM (\(kp,eshare) -> do p <- PVSS.shareDecrypt kp eshare return $! p ) (zip participants eshares) - !verifiedShares <- timingP "verifying" $ return $ + !verifiedShares <- timingPureP "verifying" $ PVSS.getValidRecoveryShares t (zip3 eshares (map PVSS.toPublicKey participants) decryptedShares) + putStrLn (show $ t == fromIntegral (length verifiedShares)) - recovered <- timingP "recovering" $ return $ PVSS.recover $ take (fromIntegral t+1) $ decryptedShares + recovered <- timingPureP "recovering" $ PVSS.recover $ take (fromIntegral t+1) $ decryptedShares + putStrLn $ show $ PVSS.escrowSecret e putStrLn $ show recovered +goScrapeDDH :: SCRAPE.Threshold -> Int -> IO () +goScrapeDDH t n = do + keypairParticipants <- {-timingP "keypair"-} (replicateM n $ PVSS.keyPairGenerate) + () <- deepseq keypairParticipants (return ()) + let participantsPublicKeys = map PVSS.toPublicKey keypairParticipants + participants = SCRAPE.Participants participantsPublicKeys + + (extraGen, sec, esis, commitments, _proof, parallelProofs) <- timingP "escrow" $ SCRAPE.escrow t participants + + !_validated <- timingP "validating" $ SCRAPE.verifyEncryptedShares extraGen t commitments parallelProofs esis participants + --putStrLn ("encrypted validated: " ++ show validated) + + !decryptedShares <- timingP "decrypting" $ mapM (\(kp,eshare) -> do + p <- SCRAPE.shareDecrypt kp eshare + return $! p + ) (zip keypairParticipants esis) + + let select = take $ fromIntegral t + !v <- timingPureP "verifying-decrypted" $ + and $ map (SCRAPE.verifyDecryptedShare) $ select $ zip3 esis participantsPublicKeys decryptedShares + putStrLn $ show v + + recovered <- timingPureP "recovering" $ SCRAPE.recover $ zip [1..] $ select decryptedShares + putStrLn $ "secret : " ++ show sec + putStrLn $ "recovered: " ++ show recovered + +#ifdef VERSION_mcl +goScrapeBDS :: Int -> Int -> IO () +goScrapeBDS t n = do + (dp, parties) <- timingP "setup" $ SCRAPE_BDS.setup n + + (secret, encryptedShares, commitments) <- timingP "distribution" $ + SCRAPE_BDS.distribution dp parties t + + timingP "verification" $ + SCRAPE_BDS.verification dp t parties encryptedShares commitments + + recoveredSecret <- timingP "reconstruction" $ + SCRAPE_BDS.reconstruction dp (V.take t) parties encryptedShares commitments + + unless (secret == recoveredSecret) $ do + fail $ "secret and recoveredSecret do not match: secret = " + ++ show secret ++ ", recoveredSecret = " ++ show recoveredSecret + + putStrLn $ "secret: " ++ show recoveredSecret +#endif + main :: IO () main = do args <- getArgs case args of - [tS, nS] -> go (read tS) (read nS) - _ -> error "error: pvss " +#ifdef VERSION_mcl + ["scrape-bds", tS, nS] -> goScrapeBDS (read tS) (read nS) +#endif + ["scrape-ddh", tS, nS] -> goScrapeDDH (read tS) (read nS) + ["pvss", tS, nS] -> go (read tS) (read nS) + _ -> error $ "error: pvss [" ++ scrapeVersions ++ "] " + where + scrapeVersions = intercalate "|" + [ "scrape-ddh" +#ifdef VERSION_mcl + , "scrape-bds" +#endif + , "pvss" + ] diff --git a/pvss.cabal b/pvss.cabal --- a/pvss.cabal +++ b/pvss.cabal @@ -1,51 +1,69 @@ name: pvss -Version: 0.1 +Version: 0.2.0 synopsis: Public Verifiable Secret Sharing description: Please see README.md homepage: https://github.com/input-output-hk/pvss-haskell#readme -license: BSD3 +license: MIT license-file: LICENSE author: Vincent Hanquez maintainer: vincent.hanquez@iohk.io copyright: 2016 IOHK category: Crypto build-type: Simple --- extra-source-files: +extra-source-files: README.md cabal-version: >=1.10 +Flag scrape-bds + Description: Build BDS version of PVSS-SCRAPE protocol + Manual: True + Default: False + library hs-source-dirs: src exposed-modules: Crypto.PVSS + Crypto.SCRAPE other-modules: Crypto.PVSS.ECC Crypto.PVSS.DLEQ Crypto.PVSS.Polynomial - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.7 && < 6 , memory , deepseq , binary , bytestring , cryptonite , cryptonite-openssl >= 0.3 + , foundation >= 0.0.7 , integer-gmp default-language: Haskell2010 + ghc-options: -Wall + if flag(scrape-bds) + exposed-modules: Crypto.SCRAPE.BDS + build-depends: mcl, + vector + if impl(ghc < 8.0) + Buildable: False + executable pvss-exe + default-language: Haskell2010 hs-source-dirs: app main-is: Main.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: base + build-depends: base >= 4.7 && < 6 , deepseq , memory , hourglass , cryptonite , pvss + , vector default-language: Haskell2010 test-suite pvss-test + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - build-depends: base + build-depends: base >= 4.7 && < 6 , cryptonite , pvss , tasty diff --git a/src/Crypto/PVSS.hs b/src/Crypto/PVSS.hs --- a/src/Crypto/PVSS.hs +++ b/src/Crypto/PVSS.hs @@ -62,10 +62,17 @@ 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) -- | The number of shares needed to reconstitute the secret +-- +-- Threshold need to be a strictly positive, and less or equal to number of participants +-- given N the number of participants, this should hold: 1 <= t <= N type Threshold = Integer -- | The number of parties in the scheme @@ -127,7 +134,7 @@ => Threshold -> randomly Escrow escrowNew threshold = do - poly <- Polynomial.generate (fromIntegral threshold) + poly <- Polynomial.generate (Polynomial.Degree $ fromIntegral threshold - 1) gen <- pointFromSecret <$> keyGenerate let secret = Polynomial.atZero poly @@ -153,10 +160,14 @@ => Threshold -- ^ PVSS scheme configuration n/t threshold -> [PublicKey] -- ^ Participants public keys -> 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) +escrow t pubs + | t < 1 = error "cannot create PVSS with threshold < 1" + | t > fromIntegral n = error "cannot create PVSS with threshold above number of participants" + | otherwise = do + e <- escrowNew t + (commitments, eshares) <- escrowWith e pubs + return (escrowExtraGen e, escrowSecret e, escrowProof e, commitments, eshares) + where n = length pubs -- | Escrow with a given polynomial escrowWith :: MonadRandom randomly @@ -269,29 +280,32 @@ -- | Recover the DhSecret used -- --- Need to pass the correct amount of shares (threshold), +-- Need to pass the correct amount of shares (# threshold), -- preferably from a 'getValidRecoveryShares' call recover :: [DecryptedShare] -> Secret recover shares = - Secret $ foldl' interpolate pointIdentity (zip shares [0..]) + Secret $ foldl' (.+) pointIdentity $ map interpolate (zip shares [0..]) where t = fromIntegral $ length shares + aShares = fromList shares - interpolate :: Point -> (DecryptedShare, ShareId) -> Point - interpolate !result (share, sid) = result .+ (shareDecryptedVal share .* value) + interpolate :: (DecryptedShare, ShareId) -> Point + interpolate (share, sid) = shareDecryptedVal share .* calc 0 (keyFromNum 1) where - value = calc 0 (keyFromNum 1) + !si = keyFromNum $ decryptedShareID (aShares `unsafeIndex` fromIntegral sid) calc :: Integer -> Scalar -> Scalar - calc !j acc + 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 + let sj = keyFromNum $ decryptedShareID (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) + -- | Get #Threshold decrypted share that are deemed valid getValidRecoveryShares :: Threshold diff --git a/src/Crypto/PVSS/DLEQ.hs b/src/Crypto/PVSS/DLEQ.hs --- a/src/Crypto/PVSS/DLEQ.hs +++ b/src/Crypto/PVSS/DLEQ.hs @@ -3,8 +3,13 @@ module Crypto.PVSS.DLEQ ( DLEQ(..) , Proof(..) + , ParallelProof(..) + , ParallelProofs(..) + , Challenge , generate , verify + , generateParallel + , verifyParallel ) where import Control.DeepSeq @@ -39,6 +44,20 @@ instance Binary Proof instance NFData Proof +newtype ParallelProof = ParallelProof { parallelProof_z :: Scalar } + deriving (Show,Eq,Generic) + +instance Binary ParallelProof +instance NFData ParallelProof + +data ParallelProofs = ParallelProofs + { parallelProofsChallenge :: !Challenge + , parallelProofsValues :: ![ParallelProof] + } deriving (Show,Eq,Generic) + +instance Binary ParallelProofs +instance NFData ParallelProofs + -- | Generate a proof generate :: Scalar -- ^ random value -> Scalar -- ^ a @@ -62,3 +81,37 @@ c = keyFromBytes ch a1 = r1 .- (h1 .* c) a2 = r2 .- (h2 .* c) + +-- | Generate all the proofs with a commonly computed challenge +generateParallel :: [(Scalar, Scalar, DLEQ)] -- (random value w, secret a, DLEQ parameter) + -> ParallelProofs +generateParallel l = + let as = map (\(r, _, (DLEQ g1 _ g2 _)) -> (g1 .* r, g2 .* r)) l + h = concatMap (\(_, _, (DLEQ _ v1 _ v2)) -> [v1,v2]) l + ++ concatMap (\(a1, a2) -> [a1,a2]) as + -- all v1,v2 followed by all (a1,a2) + challenge = hashPoints h + c = keyFromBytes challenge + + in ParallelProofs + { parallelProofsChallenge = Challenge challenge + , parallelProofsValues = map (\(w, a, _) -> ParallelProof (w #+ (a #* c))) l + } + +-- | verify proof with a commonly computed challenge +verifyParallel :: [DLEQ] + -> ParallelProofs + -> Bool +verifyParallel dleqs proofs = + let computed = zipWith verifyOne dleqs (parallelProofsValues proofs) + in ch == hashPoints (concatMap fst computed ++ concatMap snd computed) + where + (Challenge ch) = parallelProofsChallenge proofs + verifyOne :: DLEQ -> ParallelProof -> ([Point], [Point]) + verifyOne (DLEQ g1 h1 g2 h2) (ParallelProof r) = ([h1,h2], [a1,a2]) + where + r1 = g1 .* r + r2 = g2 .* r + c = keyFromBytes ch + a1 = r1 .- (h1 .* c) + a2 = r2 .- (h2 .* c) diff --git a/src/Crypto/PVSS/ECC.hs b/src/Crypto/PVSS/ECC.hs --- a/src/Crypto/PVSS/ECC.hs +++ b/src/Crypto/PVSS/ECC.hs @@ -25,6 +25,7 @@ , (.-) , (.*) , (*.) + , mulAndSum , mulPowerAndSum , hashPoints , hashPointsToKey @@ -185,6 +186,9 @@ Scalar $ expFast a n order where order = SSL.ecGroupGetOrder p256 + +mulAndSum :: [(Point,Scalar)] -> Point +mulAndSum l = Point $ SSL.ecPointsMulAndSum p256 (map (\(Point p, Scalar s) -> (p, s)) l) mulPowerAndSum :: [Point] -> Integer -> Point mulPowerAndSum l n = Point $ SSL.ecPointsMulOfPowerAndSum p256 (map unPoint l) n diff --git a/src/Crypto/PVSS/Polynomial.hs b/src/Crypto/PVSS/Polynomial.hs --- a/src/Crypto/PVSS/Polynomial.hs +++ b/src/Crypto/PVSS/Polynomial.hs @@ -1,27 +1,46 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} module Crypto.PVSS.Polynomial ( Polynomial(..) + , Degree(..) , generate , evaluate , atZero + , lambda ) where import Crypto.PVSS.ECC import Crypto.Random import Control.Monad import Control.DeepSeq -import Data.List +import Foundation.Array +import Foundation.Collection ((!), length, foldl') +import Foundation (Offset(..), CountOf(..)) +import qualified Foundation as F ((+)) +import Prelude hiding (length) -- | a group of coefficient starting from the -- smallest degree. newtype Polynomial = Polynomial [Scalar] deriving (Show,Eq,NFData) -generate :: MonadRandom randomly => Int -> randomly Polynomial -generate i - | i <= 0 = error ("invalid polynomial degree: " ++ show i) - | otherwise = Polynomial <$> replicateM i keyGenerate +-- | Degree of a polynomial +-- +-- Degree 0 : constant : P(x) = C +-- Degree 1 : linear : P(x) = C0 + C1 * x +-- .. +-- Degree n : : P(x) = C0 + C1 * x + ... + Cn * x^n +newtype Degree = Degree Int + deriving (Show,Eq,NFData) +-- | Generate a polynomial of the specified degree n +-- +-- a0 + a1 * x + a2 * x^2 + ... + an-1 * x^n-1 +generate :: MonadRandom randomly => Degree -> randomly Polynomial +generate (Degree i) + | i < 0 = error ("invalid polynomial degree: " ++ show i) + | otherwise = Polynomial <$> replicateM (i+1) keyGenerate + evaluate :: Polynomial -> Scalar -> Scalar evaluate (Polynomial a) v = foldl' (#+) (keyFromNum 0) $ zipWith (#*) a es @@ -30,3 +49,21 @@ atZero :: Polynomial -> Scalar atZero (Polynomial coeffs) = coeffs !! 0 + +-- | Lambda polynomial value for lagrange interpolation +-- +-- Lambda(i) = Product ( s(j) / (s(j) - s(i)) ) +-- +lambda :: Array Scalar -> Offset Scalar -> Scalar +lambda xs i = factor (Offset 0) (keyFromNum 1) + where + !xi = xs !!! i + !(CountOf len) = length xs + factor !j !acc + | j == Offset len = acc + | j == i = factor (j F.+ Offset 1) acc + | otherwise = + let xj = xs !!! j + e = xj #* keyInverse (xj #- xi) + in factor (j F.+ Offset 1) (acc #* e) + (!!!) arr idx = maybe (error $ "out of bound: " ++ show idx ++ " " ++ show i) id (arr ! idx) diff --git a/src/Crypto/SCRAPE.hs b/src/Crypto/SCRAPE.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/SCRAPE.hs @@ -0,0 +1,323 @@ +-- Implementation of SCRAPE - in DDH +-- +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Crypto.SCRAPE + ( + -- * Simple alias + Threshold + , ShareId + , ExtraGen(..) + , Point + , DLEQ.Proof + , DLEQ.ParallelProofs + , Scalar + , Secret(..) + , Participants(..) + , PublicKey(..) + , PrivateKey(..) + , KeyPair(..) + , DhSecret(..) + -- * Types + , Escrow(..) + , Commitment(..) + , EncryptedSi(..) + , DecryptedShare(..) + -- * method + , escrow + , escrowWith + , escrowNew + , shareDecrypt + , verifyEncryptedShares + , verifyDecryptedShare + , verifySecret + , recover + , secretToDhSecret + , reorderDecryptShares + -- * temporary export to get testing + , 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) + +-- | The number of shares needed to reconstitute the secret. +-- +-- When the threshold is reached, as in the number of decrypted +-- shares is equal or more than the threshold, the secret should +-- be recoverable through the protocol +-- +-- Threshold need to be a strictly positive, and less to number of participants +-- given N the number of participants, this should hold: 1 <= t < N +type Threshold = Integer + +-- | The ID associated with a share +type ShareId = Integer + +-- | Extra generator +newtype ExtraGen = ExtraGen Point + deriving (Show,Eq,NFData,Binary) + +-- | Secret +newtype Secret = Secret Point + deriving (Show,Eq,NFData,Binary) + +-- | Transform a secret into a usable random value +secretToDhSecret :: Secret -> DhSecret +secretToDhSecret (Secret p) = pointToDhSecret p + +-- | i'th share value +newtype Si = Si Scalar + +-- | Encrypted i'th share value with i'th public key +newtype EncryptedSi = EncryptedSi Point + deriving (Show,Eq,Generic,NFData,Binary) + +-- | An decrypted share decrypted by a party's key and +data DecryptedShare = DecryptedShare + { shareDecryptedVal :: !Point -- ^ decrypted share + , decryptedValidProof :: !DLEQ.Proof -- ^ proof the decryption is valid + } 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 + +-- | This is a list of participants in one instance of SCRAPE +-- +-- The list has a specific *order*, and the order is important to +-- be kept between various calls in this protocol. +newtype Participants = Participants [PublicKey] + deriving (Show,Eq,Generic) + +instance NFData Participants +instance Binary Participants + +-- | Prepare a new escrowing context +-- +-- The only needed parameter is the threshold +-- do not re-use an escrow context for different context. +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 + } + +-- | Prepare a secret into public encrypted shares for distributions using the PVSS scheme +-- +-- returns: +-- * the encrypted secret +-- * the list of public commitments to the scheme +-- * The encrypted shares that should be distributed to each partipants. +escrow :: MonadRandom randomly + => Threshold -- ^ PVSS scheme configuration n/t threshold + -> Participants -- ^ Participants public keys + -> 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 + +-- | Escrow with a given polynomial +escrowWith :: MonadRandom randomly + => Escrow + -> Participants -- ^ Participants public keys + -> 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) + + -- TODO clean this up + 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" + +-- | Decrypt an Encrypted share using the party's key pair. +-- Doesn't verify if an encrypted share is valid, for this +-- you need to have use 'verifyEncryptedShares' +-- +-- 1) compute Si = Yi ^ (1/xi) = G^(p(i)) +-- 2) create a proof of the valid decryption +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) + +-- | Verify a decrypted share against the public key and the encrypted share +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 + +-- | Verify that a secret recovered is the one escrow +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)] -- the list of participant decrypted share identified by a public key + -> 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 the DhSecret used +-- +-- Need to pass the correct amount of shares (threshold), +-- preferably from a 'reorderDecryptShares' call +recover :: [(ShareId, DecryptedShare)] -- the list of participant decrypted share identified by a public key + -> 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) + diff --git a/src/Crypto/SCRAPE/BDS.hs b/src/Crypto/SCRAPE/BDS.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/SCRAPE/BDS.hs @@ -0,0 +1,200 @@ +-- Implementation of SCRAPE - in BDS +-- +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Crypto.SCRAPE.BDS + ( DP(..) + , PubKey(..) + , PrivKey(..) + , Party(..) + , setup + , distribution + , verification + , reconstruction + ) where + +import Control.DeepSeq +import Control.Monad +import Crypto.Number.Generate +import Crypto.Random +import MCL.Curves.Fp254BNb +import qualified Data.Foldable as F +import qualified Data.Vector as V + +---------------------------------------- +-- Data structures + +data DP = DP + { g1 :: !G1 + , g2 :: !G2 + , g2' :: !G2 + } deriving (Eq, Show) + +instance NFData DP where + rnf DP{..} = rnf g1 `seq` rnf g2 `seq` rnf g2' `seq` () + +newtype PubKey = PubKey { unPubKey :: G1 } + deriving (Eq, Show, NFData) + +newtype PrivKey = PrivKey { unPrivKey :: Fr } + deriving (Eq, Show, NFData) + +data Party = Party + { pubKey :: !PubKey + , privKey :: !PrivKey + } deriving (Eq, Show) + +instance NFData Party where + rnf Party{..} = rnf pubKey `seq` rnf privKey `seq` () + +---------------------------------------- +-- Reed-Solomon codes + +newtype Polynomial = Polynomial (V.Vector Fr) + deriving (Eq, Show) + +randomPolynomial :: MonadRandom m => Int -> m Polynomial +randomPolynomial n + | n >= 0 = Polynomial <$> V.replicateM n randomFr + | otherwise = error $ "negative degree of a polynomial: " ++ show n + +evalPolynomial :: Fr -> Polynomial -> Fr +evalPolynomial a (Polynomial p) = snd $ V.foldl' f (1, 0) p + where + f :: (Fr, Fr) -> Fr -> (Fr, Fr) + f (!x, !result) coeff = (a*x, coeff*x + result) + +rsCode :: Int -> Polynomial -> V.Vector Fr +rsCode n poly = V.generate n $ \j -> let i = j + 1 in + evalPolynomial (fromIntegral i) poly + +rsDualCode :: Int -> Polynomial -> V.Vector Fr +rsDualCode n poly = V.generate n $ \k -> let i = k + 1 in + coeff i * evalPolynomial (fromIntegral i) poly + where + coeff :: Int -> Fr + coeff i = go n 1 + where + go :: Int -> Fr -> Fr + go j !acc + | j == 0 = acc + | j == i = go (j - 1) $ acc + | otherwise = go (j - 1) $ acc * recip (fromIntegral $ i - j) + +---------------------------------------- +-- Misc + +randomFr :: MonadRandom m => m Fr +randomFr = mkFr <$> generateMax fr_modulus + +encryptShare :: PubKey -> Fr -> G1 +encryptShare (PubKey g) m = g `g1_powFr` m + +decryptShare :: PrivKey -> G1 -> G1 +decryptShare (PrivKey k) g = g `g1_powFr` recip k + +verifyCheck :: Monad m => String -> V.Vector Bool -> m () +verifyCheck f check = (`V.imapM_` check) $ \i success -> unless success $ do + fail $ f ++ ": share " ++ show i ++ " is invalid" + +---------------------------------------- +-- Protocol phases + +setup + :: MonadRandom m + => Int + -> m (DP, V.Vector Party) +setup n = do + parties <- V.replicateM n $ do + privKey@(PrivKey k) <- PrivKey <$> randomFr + let pubKey = PubKey $ g1 `g1_powFr` k + return Party{..} + return (DP{..}, parties) + where + g1 = mapToG1 1 + g2 = mapToG2 2 + g2' = mapToG2 3 + +distribution + :: MonadRandom m + => DP + -> V.Vector Party + -> Int + -> m (GT, V.Vector G1, V.Vector G2) +distribution DP{..} parties t = do + poly <- randomPolynomial t + let s = evalPolynomial 0 poly + secret = pairing g1 g2' `gt_powFr` s + + let shares = rsCode (V.length parties) poly + + encryptedShares = (`V.imap` parties) $ \i party -> + encryptShare (pubKey party) $ shares V.! i + + commitments = V.map (g2 `g2_powFr`) shares + + return (secret, encryptedShares, commitments) + +verification + :: MonadRandom m + => DP + -> Int + -> V.Vector Party + -> V.Vector G1 + -> V.Vector G2 + -> m () +verification DP{..} t parties encryptedShares commitments = do + let sharesCheck = (`V.imap` parties) $ \i p -> + let e1 = pairing (encryptedShares V.! i) g2 + e2 = pairing (unPubKey $ pubKey p) (commitments V.! i) + in e1 == e2 + + verifyCheck "verification" sharesCheck + + let n = V.length parties + poly <- randomPolynomial $ n - t - 1 + let code = rsDualCode n poly + result = F.fold $ V.imap (\i v -> v `g2_powFr` (code V.! i)) commitments + + unless (result == g2_zero) $ do + fail $ "verification: shares are invalid, " ++ show result ++ " is not 0" + +reconstruction + :: MonadRandom m + => DP + -> (forall t. V.Vector t -> V.Vector t) + -> V.Vector Party + -> V.Vector G1 + -> V.Vector G2 + -> m GT +reconstruction DP{..} select allParties allEncryptedShares allCommitments = do + let shares = V.imap (\i -> decryptShare (privKey $ parties V.! i)) encryptedShares + sharesCheck = (`V.imap` shares) $ \i share -> + pairing share g2 == pairing g1 (commitments V.! i) + + verifyCheck "reconstruction" sharesCheck + + let result = F.fold $ V.imap (\i share -> share `g1_powFr` coeff i) shares + return $ pairing result g2' + where + ids = select $ V.enumFromTo 1 (V.length allParties) + parties = select allParties + encryptedShares = select allEncryptedShares + commitments = select allCommitments + + coeff :: Int -> Fr + coeff i = go 0 1 + where + t = V.length ids + + go :: Int -> Fr -> Fr + go j !acc + | j == t = acc + | j == i = go (j + 1) $ acc + | otherwise = + let id_i = ids V.! i + id_j = ids V.! j + in go (j + 1) $ acc * fromIntegral id_j / fromIntegral (id_j - id_i) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,6 +3,7 @@ import Control.Monad import Crypto.Random import qualified Crypto.PVSS as PVSS +import qualified Crypto.SCRAPE as SCRAPE import Test.Tasty import Test.Tasty.QuickCheck @@ -12,10 +13,21 @@ newtype Participants = Participants Integer deriving (Show,Eq) +data KofN = KofN PVSS.Threshold Integer + deriving (Show,Eq) + instance Arbitrary Threshold where - arbitrary = Threshold <$> choose (2,5) + arbitrary = Threshold <$> choose (1,5) instance Arbitrary Participants where - arbitrary = Participants <$> choose (3,10) + arbitrary = Participants <$> choose (2,10) + +instance Arbitrary KofN where + arbitrary = do + n <- choose (3,20) + t <- choose (1,8) + pure $ if t >= n then KofN t (t+1) + else KofN t n + instance Show ChaChaDRG where show _ = "chachaDRG" instance Arbitrary ChaChaDRG where @@ -82,9 +94,80 @@ (decryptedShares, _) = withDRG rng3 $ do mapM (\(kp,eshare) -> PVSS.shareDecrypt kp eshare) (zip participants eshares) +----------------------------------------------- +-- SCRAPE test + +scrapeEncryptVerify :: KofN -> ChaChaDRG -> Property +scrapeEncryptVerify (KofN threshold nOrig) rng = + let (r, _) = withDRG rng3 $ SCRAPE.verifyEncryptedShares egen threshold commitments proofs eshares participants + in r === True + where + n :: Integer + n = max (threshold) nOrig + + (participantAll, rng2) = withDRG rng $ replicateM (fromIntegral n) PVSS.keyPairGenerate + participants = SCRAPE.Participants $ map toPk participantAll + + ((egen, sec, eshares, commitments, proof, proofs), rng3) = withDRG rng2 $ + SCRAPE.escrow threshold participants + +scrapeDecryptVerify :: KofN -> ChaChaDRG -> Property +scrapeDecryptVerify (KofN threshold nOrig) rng = + map (SCRAPE.verifyDecryptedShare) (zip3 eshares (map toPk participantAll) decryptedShares) + === map (const True) eshares + where + n :: Integer + n = max (threshold) nOrig + + (participantAll, rng2) = withDRG rng $ replicateM (fromIntegral n) SCRAPE.keyPairGenerate + participants = SCRAPE.Participants $ map toPk participantAll + + ((egen, sec, eshares, commitments, proof, proofs), rng3) = withDRG rng2 $ + SCRAPE.escrow threshold participants + (decryptedShares, _) = withDRG rng3 $ do + mapM (\(kp,eshare) -> SCRAPE.shareDecrypt kp eshare) (zip participantAll eshares) + +scrapeSecretVerify :: KofN -> ChaChaDRG -> Property +scrapeSecretVerify (KofN threshold nOrig) rng = + SCRAPE.verifySecret egen threshold commitments sec secProof === True + where + n :: Integer + n = max (threshold) nOrig + + (participantAll, rng2) = withDRG rng $ replicateM (fromIntegral n) SCRAPE.keyPairGenerate + participants = SCRAPE.Participants $ map toPk participantAll + + ((egen, sec, eshares, commitments, secProof, proofs), rng3) = withDRG rng2 $ + SCRAPE.escrow threshold participants + +scrapeRecovery :: KofN -> ChaChaDRG -> Property +scrapeRecovery (KofN threshold nOrig) rng = + + let recovered = SCRAPE.recover $ take (fromIntegral (threshold+1)) $ zip [1..] decryptedShares + in recovered === sec + + where + n :: Integer + n = max (threshold) nOrig + + (participants, rng2) = withDRG rng $ replicateM (fromIntegral n) SCRAPE.keyPairGenerate + + ((egen, sec, eshares, commitments, proof, proofs), rng3) = withDRG rng2 $ + SCRAPE.escrow threshold (SCRAPE.Participants $ map toPk participants) + + (decryptedShares, _) = withDRG rng3 $ do + mapM (\(kp,eshare) -> SCRAPE.shareDecrypt kp eshare) (zip participants eshares) + main :: IO () main = defaultMain $ testGroup "PVSS" - [ testProperty "encrypted-verified" testEncryptVerify - , testProperty "decrypted-verified" testDecryptVerify - , testProperty "secret-verified" testSecretVerify - , testProperty "recovery" testRecovery ] + [ testGroup "schoenmaker" + [ testProperty "encrypted-verified" testEncryptVerify + , testProperty "decrypted-verified" testDecryptVerify + , testProperty "secret-verified" testSecretVerify + , testProperty "recovery" testRecovery ] + , testGroup "scrape" + [ testProperty "encrypted-verified" scrapeEncryptVerify + , testProperty "decrypted-verified" scrapeDecryptVerify + , testProperty "secret-verified" scrapeSecretVerify + , testProperty "recovery" scrapeRecovery ] + ]