pvss 0.1 → 0.2.0

raw patch · 11 files changed

+883/−48 lines, 11 filesdep +foundationdep +mcldep +vectordep ~basedep ~deepseqdep ~integer-gmpPVP ok

version bump matches the API change (PVP)

Dependencies added: foundation, mcl, vector

Dependency ranges changed: base, deepseq, integer-gmp

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README.md +11/−0
• app/Main.hs +107/−15
• pvss.cabal +24/−6
• src/Crypto/PVSS.hs +29/−15
• src/Crypto/PVSS/DLEQ.hs +53/−0
• src/Crypto/PVSS/ECC.hs +4/−0
• src/Crypto/PVSS/Polynomial.hs +42/−5
• src/Crypto/SCRAPE.hs +323/−0
• src/Crypto/SCRAPE/BDS.hs +200/−0
• test/Spec.hs +89/−6

@@ -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

@@ -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.

@@ -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 <threshold> <number>"+#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 ++ "] <threshold> <number>"+  where+    scrapeVersions = intercalate "|"+      [ "scrape-ddh"+#ifdef VERSION_mcl+      , "scrape-bds"+#endif+      , "pvss"+      ]

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -0,0 +1,323 @@+-- Implementation of SCRAPE - in DDH+--+--	<http://eprint.iacr.org/2017/216>+{-# 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)+

@@ -0,0 +1,200 @@+-- Implementation of SCRAPE - in BDS+--+--	<http://eprint.iacr.org/2017/216>+{-# 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)

@@ -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 ]+    ]