diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2016 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 +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to +do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import System.Environment +import Control.Monad +import Control.DeepSeq +import Crypto.Random +import qualified Crypto.PVSS as PVSS +import Data.Hourglass +import Time.Types +import Time.System + +timing f = do + t1 <- timeCurrentP + a <- f + t2 <- a `deepseq` timeCurrentP + return (a, t2 `timeDiffP` t1) + +timingP n f = do + (a, t) <- timing f + putStrLn (n ++ ": " ++ show t) + return a + +chunk _ [] = [] +chunk n l = + let (l1,l2) = splitAt n l + in l1 : chunk n l2 + +go t n = do + participants <- replicateM n $ PVSS.keyPairGenerate + + !e <- timingP "escrow-new" $ PVSS.escrowNew t + + !commitments <- timingP "commitments" $ return $ PVSS.createCommitments e + + !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 + + + validated <- timingP "validating" $ forM (chunk 200 $ zip eshares (map PVSS.toPublicKey participants)) $ \c -> + timingP ("vchunk") $ forM c $ return . PVSS.verifyEncryptedShare (PVSS.escrowExtraGen e) commitments + + !decryptedShares <- timingP "decrypting" $ mapM (\(kp,eshare) -> do + p <- PVSS.shareDecrypt kp eshare + return $! p + ) (zip participants eshares) + + !verifiedShares <- timingP "verifying" $ return $ + PVSS.getValidRecoveryShares t (zip3 eshares (map PVSS.toPublicKey participants) decryptedShares) + + recovered <- timingP "recovering" $ return $ PVSS.recover $ take (fromIntegral t+1) $ decryptedShares + putStrLn $ show recovered + +main :: IO () +main = do + args <- getArgs + case args of + [tS, nS] -> go (read tS) (read nS) + _ -> error "error: pvss " diff --git a/pvss.cabal b/pvss.cabal new file mode 100644 --- /dev/null +++ b/pvss.cabal @@ -0,0 +1,58 @@ +name: pvss +Version: 0.1 +synopsis: Public Verifiable Secret Sharing +description: Please see README.md +homepage: https://github.com/input-output-hk/pvss-haskell#readme +license: BSD3 +license-file: LICENSE +author: Vincent Hanquez +maintainer: vincent.hanquez@iohk.io +copyright: 2016 IOHK +category: Crypto +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Crypto.PVSS + other-modules: Crypto.PVSS.ECC + Crypto.PVSS.DLEQ + Crypto.PVSS.Polynomial + build-depends: base >= 4.7 && < 5 + , memory + , deepseq + , binary + , bytestring + , cryptonite + , cryptonite-openssl >= 0.3 + , integer-gmp + default-language: Haskell2010 + +executable pvss-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , deepseq + , memory + , hourglass + , cryptonite + , pvss + default-language: Haskell2010 + +test-suite pvss-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , cryptonite + , pvss + , tasty + , tasty-quickcheck + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/input-output-hk/pvss-haskell diff --git a/src/Crypto/PVSS.hs b/src/Crypto/PVSS.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/PVSS.hs @@ -0,0 +1,311 @@ +-- Implementation of the Public Verifiable Secret Scheme based on Berry Schoenmakers's paper: +-- +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS -Wno-unused-top-binds #-} +{-# OPTIONS -Wno-name-shadowing #-} +{-# OPTIONS -Wno-unused-matches #-} + +module Crypto.PVSS + ( + -- * Simple alias + Threshold + , ShareId + , ExtraGen + , Point + , DLEQ.Proof + , Scalar + , Secret + , PublicKey(..) + , PrivateKey(..) + , KeyPair(..) + , DhSecret(..) + -- * Types + , Escrow(..) + , Commitment + , EncryptedShare(..) + , DecryptedShare(..) + -- * method + , escrow + , escrowWith + , escrowNew + , createCommitments + , sharesCreate + , shareCreate + , shareDecrypt + , verifyEncryptedShare + , verifyDecryptedShare + , verifySecret + , getValidRecoveryShares + , recover + , secretToDhSecret + -- * temporary export to get testing + , 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) + +-- | The number of shares needed to reconstitute the secret +type Threshold = Integer + +-- | The number of parties in the scheme +type Participants = 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 + +-- | An encrypted share associated to a party's key. +data EncryptedShare = EncryptedShare + { shareID :: !ShareId + , shareEncryptedVal :: !Point -- ^ encrypted by participant public key + , shareValidProof :: !DLEQ.Proof -- ^ proof it's a valid share + } 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 + +-- | An decrypted share decrypted by a party's key and +data DecryptedShare = DecryptedShare + { decryptedShareID :: !ShareId + , 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 <$> (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 + +-- | 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 (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 + } + +-- | Prepare a secret into public encrypted shares for distributions using the PVSS scheme +-- +-- returns: +-- * the encrypted secret which is locked symmetrically to the DH-secret (g^random) +-- * the list of public commitments (Cj) to the scheme +-- * The encrypted shares that should be distributed to each partipants. +escrow :: MonadRandom randomly + => 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 with a given polynomial +escrowWith :: MonadRandom randomly + => Escrow + -> [PublicKey] -- ^ Participants public keys + -> randomly ([Commitment], [EncryptedShare]) +escrowWith escrow pubs = do + let commitments = createCommitments escrow + + -- create the encrypted shares Yi + proof + encryptedShares <- sharesCreate escrow commitments pubs + + return (commitments, encryptedShares) + +-- | Create all the commitments +-- +-- there is commitments in the list +createCommitments :: Escrow -> [Commitment] +createCommitments escrow = + -- create commitments Cj = g ^ aj + map (\c -> Commitment (g .* c)) polyCoeffs + where + Polynomial polyCoeffs = escrowPolynomial escrow + ExtraGen g = escrowExtraGen escrow + +-- | Create all the encrypted share associated with specific public key +sharesCreate :: MonadRandom randomly + => Escrow + -> [Commitment] + -> [PublicKey] + -> randomly [EncryptedShare] +sharesCreate escrow commitments pubs = forM (zip [1..] pubs) $ uncurry (shareCreate escrow commitments) + +-- | Create a specific share given a public key and the overall parameters +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 -- createXi shareId commitments + 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 + +-- | Decrypt an Encrypted share using the party's key pair. +-- Doesn't verify if an encrypted share is valid, for this +-- you need to use 'verifyEncryptedShare' +-- +-- 1) compute Si = Yi ^ (1/xi) = G^(p(i)) +-- 2) create a proof of the valid decryption +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 + +-- | Verify an encrypted share +-- +-- anyone can do that given the extra generator and the commitments +verifyEncryptedShare :: ExtraGen + -> [Commitment] + -> (EncryptedShare, PublicKey) -- ^ the encrypted and the associated public key + -> 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 + +-- | Verify a decrypted share against the public key and the encrypted share +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) + +-- | Verify that a secret recovered is the one escrow +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 the DhSecret used +-- +-- 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..]) + 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) + +-- | Get #Threshold decrypted share that are deemed valid +getValidRecoveryShares :: Threshold + -> [(EncryptedShare, PublicKey, DecryptedShare)] + -> [DecryptedShare] +getValidRecoveryShares threshold shares = + map thd . take (fromIntegral threshold) . filter verifyDecryptedShare $ shares + where thd (_,_,ds) = ds + +-- | Sum all commitment multiplied by the share id raised at the power of i +-- +-- C_0 * 1 + C_1 * shareid + C_2 * shareid^2 + C_3 * shareid^3 ... + C_n * shareid^n +createXi :: ShareId -- ^ index i + -> [Commitment] -- ^ all commitments + -> Point +createXi i commitments = + mulPowerAndSum (map unCommitment commitments) (fromIntegral i) diff --git a/src/Crypto/PVSS/DLEQ.hs b/src/Crypto/PVSS/DLEQ.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/PVSS/DLEQ.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.PVSS.DLEQ + ( DLEQ(..) + , Proof(..) + , generate + , verify + ) where + +import Control.DeepSeq +import Crypto.PVSS.ECC +import Data.Binary +import Data.Binary.Get (getByteString) +import Data.Binary.Put (putByteString) +import Data.ByteString (ByteString) +import GHC.Generics + +data DLEQ = DLEQ + { dleq_g1 :: !Point -- ^ g1 parameter + , dleq_h1 :: !Point -- ^ h1 parameter where h1 = g1^a + , dleq_g2 :: !Point -- ^ g2 parameter + , dleq_h2 :: !Point -- ^ h2 parameter where h2 = g2^a + } deriving (Show,Eq,Generic) + +instance NFData DLEQ + +newtype Challenge = Challenge ByteString + deriving (Show,Eq,NFData) +instance Binary Challenge where + put (Challenge c) = putByteString c + get = Challenge <$> getByteString 32 + +-- | The generated proof +data Proof = Proof + { proof_c :: !Challenge + , proof_z :: !Scalar + } deriving (Show,Eq,Generic) + +instance Binary Proof +instance NFData Proof + +-- | Generate a proof +generate :: Scalar -- ^ random value + -> Scalar -- ^ a + -> DLEQ -- ^ DLEQ parameters to generate from + -> Proof +generate w a (DLEQ g1 h1 g2 h2) = Proof (Challenge c) r + where + a1 = g1 .* w + a2 = g2 .* w + c = hashPoints [h1,h2,a1,a2] + r = w #+ (a #* keyFromBytes c) + +-- | Verify a proof +verify :: DLEQ -- ^ DLEQ parameter used to verify + -> Proof -- ^ the proof to verify + -> Bool +verify (DLEQ g1 h1 g2 h2) (Proof (Challenge ch) r) = ch == hashPoints [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 new file mode 100644 --- /dev/null +++ b/src/Crypto/PVSS/ECC.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.PVSS.ECC + ( Point(..) + , Scalar(..) + , PublicKey(..) + , PrivateKey(..) + , KeyPair(..) + , DhSecret(..) + , curveGenerator + , pointToDhSecret + , pointFromSecret + , pointIdentity + , keyPairGenerate + , keyGenerate + , keyFromBytes + , keyFromNum + , keyInverse + , (#+) + , (#-) + , (#*) + , (#^) + , (.+) + , (.-) + , (.*) + , (*.) + , mulPowerAndSum + , hashPoints + , hashPointsToKey + ) where + +#define OPENSSL + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteArray as B (convert) +import Data.Bits +import Data.Binary +import Data.Binary.Get (getByteString) +import Data.Binary.Put (putByteString) + +import GHC.Generics +import Control.DeepSeq +import Crypto.Hash (hash, SHA256, Digest) +import Crypto.Number.Serialize +import Crypto.Number.ModArithmetic (expFast) +import Crypto.Random + +#ifdef OPENSSL +import qualified Crypto.OpenSSL.ECC as SSL +import GHC.Integer.GMP.Internals (recipModInteger) +import Crypto.Number.Generate +#else +import qualified Crypto.PubKey.ECC.P256 as P256 +#endif + +data KeyPair = KeyPair + { toPrivateKey :: PrivateKey + , toPublicKey :: PublicKey + } + deriving (Show,Eq,Generic) + +instance Binary KeyPair where + put (KeyPair priv pub) = put priv >> put pub + get = KeyPair <$> get <*> get + +instance NFData KeyPair + +newtype DhSecret = DhSecret ByteString + deriving (Show,Eq,NFData,Binary) + +keyFromBytes :: ByteString -> Scalar +keyFromBytes = keyFromNum . os2ip' + where os2ip' :: ByteString -> Integer + os2ip' = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0 + +-- | Private Key +newtype PrivateKey = PrivateKey Scalar + deriving (Show,Eq,NFData,Binary) + +-- | Public Key +newtype PublicKey = PublicKey Point + deriving (Show,Eq,NFData,Binary) + +#ifdef OPENSSL + +p256 :: SSL.EcGroup +p256 = maybe (error "p256 curve") id $ SSL.ecGroupFromCurveOID "1.2.840.10045.3.1.7" + +newtype Point = Point { unPoint :: SSL.EcPoint } + deriving (Generic) + +instance NFData Point where + rnf (Point p) = p `seq` () + +instance Show Point where + show (Point p) = + let (x,y) = SSL.ecPointToAffineGFp p256 p + in ("Point " ++ show x ++ " " ++ show y) +instance Eq Point where + (Point a) == (Point b) = SSL.ecPointEq p256 a b +instance Binary Point where + put = putByteString + . flip (SSL.ecPointToOct p256) SSL.PointConversion_Compressed + . unPoint + get = either fail (return . Point) . SSL.ecPointFromOct p256 =<< getByteString 33 + +newtype Scalar = Scalar { unScalar :: Integer } + deriving (Show,Eq,Generic,NFData) +instance Binary Scalar where + put (Scalar i) = putByteString $ i2ospOf_ 32 i + get = keyFromBytes <$> getByteString 32 + +keyFromNum :: Integer -> Scalar +keyFromNum n = Scalar (n `mod` SSL.ecGroupGetOrder p256) + +keyInverse :: Scalar -> Scalar +keyInverse (Scalar 0) = Scalar 0 +keyInverse (Scalar a) = Scalar $ recipModInteger a order + where + order = SSL.ecGroupGetOrder p256 + +keyGenerate :: MonadRandom randomly => randomly Scalar +keyGenerate = Scalar <$> generateMax order + where + order = SSL.ecGroupGetOrder p256 + +keyPairGenerate :: MonadRandom randomly => randomly KeyPair +keyPairGenerate = do + k <- keyGenerate + return $ KeyPair (PrivateKey k) (PublicKey $ pointFromSecret k) + +pointToDhSecret :: Point -> DhSecret +pointToDhSecret (Point p) = + let (x, _) = SSL.ecPointToAffineGFp p256 p + in DhSecret $ B.convert $ hashSHA256 $ i2ospOf_ 32 x + +pointFromSecret :: Scalar -> Point +pointFromSecret (Scalar s) = Point $ SSL.ecPointGeneratorMul p256 s + +pointIdentity :: Point +pointIdentity = Point $ SSL.ecPointInfinity p256 + +hashPoints :: [Point] -> ByteString +hashPoints elements = + B.convert $ hashSHA256 $ mconcat + $ fmap (flip (SSL.ecPointToOct p256) SSL.PointConversion_Compressed . unPoint) elements + +hashPointsToKey :: [Point] -> Scalar +hashPointsToKey elements = + keyFromBytes $ B.convert $ hashSHA256 $ mconcat + $ fmap (flip (SSL.ecPointToOct p256) SSL.PointConversion_Compressed . unPoint) elements + +curveGenerator :: Point +curveGenerator = Point $ SSL.ecGroupGetGenerator p256 + +-- | Point adding +(.+) :: Point -> Point -> Point +(.+) (Point a) (Point b) = Point (SSL.ecPointAdd p256 a b) + +-- | Point subtraction +(.-) :: Point -> Point -> Point +(.-) (Point a) (Point b) = Point (SSL.ecPointAdd p256 a $ SSL.ecPointInvert p256 b) + +-- | Point scaling +(.*) :: Point -> Scalar -> Point +(.*) (Point a) (Scalar s) = Point (SSL.ecPointMul p256 a s) + +-- | Point scaling, flip (*.) +(*.) :: Scalar -> Point -> Point +(*.) (Scalar s) (Point a) = Point (SSL.ecPointMul p256 a s) + +(#+) :: Scalar -> Scalar -> Scalar +(#+) (Scalar a) (Scalar b) = keyFromNum (a + b) + +(#-) :: Scalar -> Scalar -> Scalar +(#-) (Scalar a) (Scalar b) = keyFromNum (a - b) + +(#*) :: Scalar -> Scalar -> Scalar +(#*) (Scalar a) (Scalar b) = keyFromNum (a * b) + +(#^) :: Scalar -> Integer -> Scalar +(#^) (Scalar a) n = + Scalar $ expFast a n order + where + order = SSL.ecGroupGetOrder p256 + +mulPowerAndSum :: [Point] -> Integer -> Point +mulPowerAndSum l n = Point $ SSL.ecPointsMulOfPowerAndSum p256 (map unPoint l) n + +#else +newtype Point = Point { unPoint :: P256.Point } + deriving (Show,Eq) + +newtype Scalar = Scalar P256.Scalar + deriving (Eq) + +instance Show Scalar where + show (Scalar p) = show (P256.scalarToInteger p) + +p256Mod :: Integer +p256Mod = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551 + +curveGenerator :: Point +curveGenerator = pointIdentity + +pointFromSecret :: Scalar -> Point +pointFromSecret (Scalar s) = Point $ P256.toPoint s + +pointToDhSecret :: Point -> DhSecret +pointToDhSecret (Point p) = DhSecret $ B.convert $ hashSHA256 $ P256.pointToBinary p + +-- | Point adding +(.+) :: Point -> Point -> Point +(.+) (Point a) (Point b) = Point (P256.pointAdd a b) + +-- | Point scaling +(.*) :: Point -> Scalar -> Point +(.*) (Point a) (Scalar s) = Point (P256.pointMul s a) + +-- | Point scaling, flip (*.) +(*.) :: Scalar -> Point -> Point +(*.) (Scalar s) (Point a) = Point (P256.pointMul s a) + +(#+) :: Scalar -> Scalar -> Scalar +(#+) (Scalar a) (Scalar b) = Scalar (P256.scalarAdd a b) + +(#-) :: Scalar -> Scalar -> Scalar +(#-) (Scalar a) (Scalar b) = Scalar (P256.scalarSub a b) + +(#*) :: Scalar -> Scalar -> Scalar +(#*) (Scalar a) (Scalar b) = + Scalar $ throwCryptoError $ P256.scalarFromInteger ((an * bn) `mod` p256Mod) + where + an = P256.scalarToInteger a + bn = P256.scalarToInteger b + +(#^) :: Scalar -> Integer -> Scalar +(#^) (Scalar a) n = + Scalar $ throwCryptoError + $ P256.scalarFromInteger + $ expSafe (P256.scalarToInteger a) n p256Mod + +pointIdentity :: Point +pointIdentity = Point $ P256.pointFromIntegers 0 0 + +keyFromNum :: Integer -> Scalar +keyFromNum = Scalar . throwCryptoError . P256.scalarFromInteger + +keyInverse :: Scalar -> Scalar +keyInverse (Scalar s) = Scalar (P256.scalarInv s) + +keyGenerate :: MonadRandom randomly => randomly Scalar +keyGenerate = Scalar <$> P256.scalarGenerate + +keyPairGenerate :: MonadRandom randomly => randomly KeyPair +keyPairGenerate = do + k <- keyGenerate + return $ KeyPair k (pointFromSecret k) + +hashPointsToKey :: [Point] -> Scalar +hashPointsToKey elements = + keyFromBytes $ B.convert $ hashSHA256 $ mconcat $ fmap (P256.pointToBinary . unPoint) elements + +#endif + +hashSHA256 :: ByteString -> Digest SHA256 +hashSHA256 m = hash m diff --git a/src/Crypto/PVSS/Polynomial.hs b/src/Crypto/PVSS/Polynomial.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/PVSS/Polynomial.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Crypto.PVSS.Polynomial + ( Polynomial(..) + , generate + , evaluate + , atZero + ) where + +import Crypto.PVSS.ECC +import Crypto.Random +import Control.Monad +import Control.DeepSeq +import Data.List + +-- | 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 + +evaluate :: Polynomial -> Scalar -> Scalar +evaluate (Polynomial a) v = + foldl' (#+) (keyFromNum 0) $ zipWith (#*) a es + where + es = [ (v #^ degree) | degree <- [0..] ] + +atZero :: Polynomial -> Scalar +atZero (Polynomial coeffs) = coeffs !! 0 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,90 @@ +module Main where + +import Control.Monad +import Crypto.Random +import qualified Crypto.PVSS as PVSS +import Test.Tasty +import Test.Tasty.QuickCheck + +newtype Threshold = Threshold PVSS.Threshold + deriving (Show,Eq) + +newtype Participants = Participants Integer + deriving (Show,Eq) + +instance Arbitrary Threshold where + arbitrary = Threshold <$> choose (2,5) +instance Arbitrary Participants where + arbitrary = Participants <$> choose (3,10) +instance Show ChaChaDRG where + show _ = "chachaDRG" +instance Arbitrary ChaChaDRG where + arbitrary = arbitrary >>= \n -> return $ drgNewTest (0,0,0,0,n) + +toPk :: PVSS.KeyPair -> PVSS.PublicKey +toPk = PVSS.toPublicKey + +testEncryptVerify :: Threshold -> Participants -> ChaChaDRG -> Property +testEncryptVerify (Threshold threshold) (Participants nOrig) rng = + map (PVSS.verifyEncryptedShare egen commitments) (zip eshares (map toPk participants)) === map (const True) eshares + where + n :: Integer + n = max (threshold) nOrig + + (participants, rng2) = withDRG rng $ replicateM (fromIntegral n) PVSS.keyPairGenerate + + ((egen, sec, _, commitments, eshares), rng3) = withDRG rng2 $ + PVSS.escrow threshold (map toPk participants) + +testDecryptVerify :: Threshold -> Participants -> ChaChaDRG -> Property +testDecryptVerify (Threshold threshold) (Participants nOrig) rng = + map (PVSS.verifyDecryptedShare) (zip3 eshares (map toPk participants) decryptedShares) + === map (const True) eshares + where + n :: Integer + n = max (threshold) nOrig + + (participants, rng2) = withDRG rng $ replicateM (fromIntegral n) PVSS.keyPairGenerate + + ((egen, sec, _, commitments, eshares), rng3) = withDRG rng2 $ + PVSS.escrow threshold (map toPk participants) + + (decryptedShares, _) = withDRG rng3 $ do + mapM (\(kp,eshare) -> PVSS.shareDecrypt kp eshare) (zip participants eshares) + +testSecretVerify :: Threshold -> Participants -> ChaChaDRG -> Property +testSecretVerify (Threshold threshold) (Participants nOrig) rng = + PVSS.verifySecret egen commitments sec secProof === True + where + n :: Integer + n = max (threshold) nOrig + + (participants, rng2) = withDRG rng $ replicateM (fromIntegral n) PVSS.keyPairGenerate + + ((egen, sec, secProof, commitments, _), rng3) = withDRG rng2 $ + PVSS.escrow threshold (map toPk participants) + +testRecovery :: Threshold -> Participants -> ChaChaDRG -> Property +testRecovery (Threshold threshold) (Participants nOrig) rng = + + let recovered = PVSS.recover $ take (fromIntegral (threshold+1)) $ decryptedShares + in recovered === sec + + where + n :: Integer + n = max (threshold) nOrig + + (participants, rng2) = withDRG rng $ replicateM (fromIntegral n) PVSS.keyPairGenerate + + ((egen, sec, _, commitments, eshares), rng3) = withDRG rng2 $ + PVSS.escrow threshold (map toPk participants) + + (decryptedShares, _) = withDRG rng3 $ do + mapM (\(kp,eshare) -> PVSS.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 ]