diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Adjoint Inc. + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,133 @@ +

+ +

+ +Commitment Schemes +================== + +[![CircleCI](https://circleci.com/gh/adjoint-io/pedersen-commitment.svg?style=svg&circle-token=35a75a2815badbfcb8ed604037cff3203b848bd2)](https://circleci.com/gh/adjoint-io/pedersen-commitment) + +Commitment schemes are a way for one counterparty to commit to a value such that +the value committed remains private, but can be revealed at a later time when +the committing party divulges a necessary parameter of the commitment process. +Strong commitment schemes must be both information *hiding* and computationally +*binding*. + +The Pedersen commitment sheme allows a sender to create a commitment to a secret +value. They may then later open the commitment and reveal the value in a +verifiable manner that binds them to their commitment. A commitment shceme +consists of a three stages: + +1. `Setup` +2. `Commit` +3. `Open` + +```haskell +example :: IO Bool +example = do + -- Setup commitment parameters + (a, cp) <- setup 256 + + -- Commit to the message using paramaters: Com(msg, cp) + let msg = 0xCAFEBEEF + Pedersen c r <- commit msg cp + + -- Open and verify commitment: Open(cp,c,r) + pure (open cp c r) +``` + +Pedersen commitment scheme has the following properties: + +1. **Hiding**: A dishonest party cannot discover the honest party's value. +2. **Binding**: A dishonest party cannot open his or her commitment in more than one way +3. **Non-correlation**: A dishonest party cannot commit to a value that is in some + significant way correlated to the honest party's value. + +Using Pedersen commitments we implement [mutually independent +commitments](https://www.iacr.org/archive/asiacrypt2001/22480387.pdf) system, a +secure multiparty communication protocol in which counterparties can commit to +arbitrary messages or data in a binding way. + +Pedersen commitments are also additionally homomorphic, such that for messages +`m0` and `m1` and blinding factors `r0` and `r1` we have: + +``` +Commit(m0; r0) * Commit(m1; r1) = Commit(m0 + m1; r0 + r1) +``` + +### Pedersen Commitments (Elliptic Curves) + +A more efficient implementation of the Pedersen Commitment scheme arises from +Elliptic Curve Cryptography (ECC) which is based on the algebraic structure of +elliptic curves over finite (prime) fields. Using ECC, the commitment scheme +computations require fewer bits and as a result yields a much faster commitment +phase. + +Given a secure elliptic curve (e.g. secp256k1), a Pedersen +commitment can be implemented using the same interface as usual but instead +of prime field modular exponentiation, EC point multiplication and addition +are used. The use of EC Pedersen commitments is almost exactly the same as the +general prime field implementation: + +```haskell +example :: IO Bool +example = do + -- Setup commitment parameters + (a, cp) <- ecSetup Nothing -- SECP256k1 is used by default + + -- Commit to the message using paramaters: Com(msg, cp) + let msg = 0xCAFEBEEF + ECPedersen c r <- ecCommit msg cp + + -- Open and verify commitment: Open(cp,c,r) + pure (ecOpen cp c r) +``` + +Additionally, the EC Pedersen Commitment implementation is also additively +homomorphic in two ways: + +``` +Commit(x, r1) + Commit(y, r2) = Commit(x + y, r1 + r2) +``` + +and given a scalar `n`: + +``` +Commit(x,r) + n = Commit(x + n,r) +``` + + +**References**: + +1. Pedersen, Torben Pryds. "Non-interactive and information-theoretic secure verifiable secret sharing." Annual International Cryptology Conference. Springer Berlin Heidelberg, 1991. APA +2. Liskov, Moses, et al. "Mutually independent commitments." International Conference on the Theory and Application of Cryptology and Information Security. Springer Berlin Heidelberg, 2001. APA +3. Blum, Manuel, and Silvio Micali. "How to generate cryptographically strong sequences of pseudorandom bits." SIAM journal on Computing 13.4 (1984): 850-864. + +Usage +----- + +```bash +$ stack build +$ stack repl +> :load example/Example.hs +``` + +License +------- + +``` +Copyright 2017 Adjoint Inc + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +``` + diff --git a/pedersen-commitment.cabal b/pedersen-commitment.cabal new file mode 100644 --- /dev/null +++ b/pedersen-commitment.cabal @@ -0,0 +1,79 @@ +-- This file has been generated from package.yaml by hpack version 0.19.3. +-- +-- see: https://github.com/sol/hpack + +name: pedersen-commitment +version: 0.1.0 +synopsis: An implementation of Pedersen commitment schemes +description: An implementation of Pedersen commitment schemes +category: Cryptography +homepage: https://github.com/adjoint-io/pedersen-commitment#readme +bug-reports: https://github.com/adjoint-io/pedersen-commitment/issues +maintainer: Adjoint Inc (info@adjoint.io) +license: Apache +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/adjoint-io/pedersen-commitment + +flag optimized + description: Perform compiler optimizations + manual: False + default: False + +flag static + description: Emit statically-linked binary + manual: False + default: False + +library + hs-source-dirs: + src + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances + ghc-options: -fwarn-tabs -fwarn-incomplete-patterns -fwarn-incomplete-record-updates -fwarn-redundant-constraints -fwarn-implicit-prelude -fwarn-overflowed-literals -fwarn-orphans -fwarn-identities -fwarn-dodgy-exports -fwarn-dodgy-imports -fwarn-duplicate-exports -fwarn-overlapping-patterns -fwarn-missing-fields -fwarn-missing-methods -fwarn-missing-signatures -fwarn-noncanonical-monad-instances -fwarn-unused-pattern-binds -fwarn-unused-type-patterns -fwarn-unrecognised-pragmas -fwarn-wrong-do-bind -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind + build-depends: + base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.5 + , cryptonite >=0.21 + , memory >=0.14 + , mtl >=2.2 + , protolude >=0.2 + , text >=1.2 + exposed-modules: + PrimeField + Pedersen + MICP.Internal + MICP + other-modules: + Paths_pedersen_commitment + default-language: Haskell2010 + +test-suite test-suite + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + tests + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.5 + , cryptonite >=0.21 + , memory >=0.14 + , mtl >=2.2 + , pedersen-commitment + , protolude >=0.2 + , tasty + , tasty-hunit + , tasty-quickcheck + , text >=1.2 + other-modules: + Example + default-language: Haskell2010 diff --git a/src/MICP.hs b/src/MICP.hs new file mode 100644 --- /dev/null +++ b/src/MICP.hs @@ -0,0 +1,445 @@ + +module MICP ( + -- ** Initiator Phases + IPhase(..), + + IPhase1Priv, + IPhase1Msg, + iPhase1, + + IPhase2Priv, + IPhase2Params, + mkIPhase2Params, + IPhase2Msg, + iPhase2, + + IPhase3Params, + mkIPhase3Params, + IPhase3Msg(..), + iPhase3, + + IPhase4Params, + mkIPhase4Params, + IPhase4Msg, + iPhase4, + + IPhase5Msg, + iPhase5, + + iGetK1Map, + iGetK2Map, + + -- ** Responder Phases + RPhase(..), + + RPhase1Priv, + RPhase1Params, + mkRPhase1Params, + RPhase1Msg, + rPhase1, + + RPhase2Params, + mkRPhase2Params, + RPhase2Msg, + rPhase2, + + RPhase3Params, + mkRPhase3Params, + RPhase3Msg, + rPhase3, + + RPhase4Params, + mkRPhase4Params, + RPhase4Msg, + rPhase4, + + rGetK1Map, + rGetK2Map + +) where + +import Protolude + +import Crypto.Random.Types (MonadRandom(..)) + +import qualified Data.ByteArray as BA + +import qualified Pedersen as P +import PrimeField +import MICP.Internal + +------------------------------------------------------------------------------- +-- This module breaks the Mutually Independent Commitment Protocol into +-- understandable steps such that the protocol is easy to integrate into +-- existing distributed systems. +------------------------------------------------------------------------------- + +-- Intiator API + +data IPhase + = IPhase1 IPhase1Msg + | IPhase2 IPhase2Msg + | IPhase3 IPhase3Msg + | IPhase4 IPhase4Msg + | IPhase5 IPhase5Msg + +-------------------------- +-- Initiator Phase 1 +-------------------------- + +data IPhase1Priv = IPhase1Priv + { iprivA :: Integer -- ^ Exponent such that g^iA = h (pedersen) + } + +data IPhase1Msg = IPhase1Msg + { iCommitParams :: P.CommitParams -- ^ Bases to send to Responder + } + +iPhase1 :: MonadRandom m => Int -> m (IPhase1Priv, IPhase1Msg) +iPhase1 = fmap (bimap IPhase1Priv IPhase1Msg) . P.setup + +-------------------------- +-- Initiator Phase 2 +-------------------------- + +data IPhase2Params = IPhase2Params + { ip2pSecretBytes :: [Word8] + , ip2pRCommitParams :: P.CommitParams + } + +mkIPhase2Params :: ByteString -> RPhase1Msg -> IPhase2Params +mkIPhase2Params secret rp1msg = + IPhase2Params + { ip2pSecretBytes = BA.unpack secret + , ip2pRCommitParams = rCommitParams rp1msg + } + +data IPhase2Priv = IPhase2Priv + { iprivK1Map :: K1Map + , iprivK2Map :: K2Map + , iprivR :: Integer + , iprivReveal :: P.Reveal -- ^ Info to open the g^r commitment + } + +data IPhase2Msg = IPhase2Msg + { iGtoK1Map :: GtoK1Map + , iGtoK2Map :: GtoK2Map + , iCommitment :: P.Commitment -- ^ Commitment of private R value + , iC :: Integer + } + +iPhase2 :: MonadRandom m => IPhase2Params -> SPFM m (IPhase2Priv, IPhase2Msg) +iPhase2 (IPhase2Params secretBytes rcp) = do + (k1Map,k2Map) <- genKMaps secretBytes + gToK1map <- kmapToGKMap k1Map + gToK2map <- kmapToGKMap k2Map + (r,pedersen) <- genAndCommitR rcp + c <- genC + let ip2Priv = IPhase2Priv k1Map k2Map r (P.reveal pedersen) + let ip2Msg = IPhase2Msg gToK1map gToK2map (P.commitment pedersen) c + return (ip2Priv, ip2Msg) + +-------------------------- +-- Initiator Phase 3 +-------------------------- + +data IPhase3Params = IPhase3Params + { ip3pRCommitment :: P.Commitment + , ip3pRReveal :: P.Reveal + , ip3pRDMap :: DMap + , ip3pRGtoK1Map :: GtoK1Map + , ip3pRC :: Integer + , ip3pICommitParams :: P.CommitParams + , ip3pIC :: Integer + , ip3pK1Map :: K1Map + , ip3pIR :: Integer + , ip3pIReveal :: P.Reveal + , ip3pA :: Integer + } + +mkIPhase3Params + :: IPhase1Priv + -> IPhase1Msg + -> IPhase2Priv + -> IPhase2Msg + -> RPhase1Msg + -> RPhase2Msg + -> IPhase3Params +mkIPhase3Params ip1priv ip1msg ip2priv ip2msg rp1msg rp2msg = + IPhase3Params + { ip3pRCommitment = rCommit rp1msg + , ip3pRReveal = rReveal rp2msg + , ip3pRDMap = rDMap rp2msg + , ip3pRGtoK1Map = rGtoK1Map rp1msg + , ip3pRC = rC rp2msg + , ip3pICommitParams = iCommitParams ip1msg + , ip3pIC = iC ip2msg + , ip3pK1Map = iprivK1Map ip2priv + , ip3pIR = iprivR ip2priv + , ip3pIReveal = iprivReveal ip2priv + , ip3pA = iprivA ip1priv + } + +data IPhase3Msg + = IPhase3Reject + | IPhase3Msg + { iReveal :: P.Reveal + , iDMap :: DMap + , iA :: Integer + } + +iPhase3 :: MonadRandom m => IPhase3Params -> SPFM m IPhase3Msg +iPhase3 (IPhase3Params rcom rrev rdmap rgtok1map rc icp ic ik1map ir irev ia) + | P.open icp rcom rrev = do + dmapIsValid <- verifyDMap rdmap rgtok1map ic $ P.revealVal rrev + if dmapIsValid then + return IPhase3Msg + { iReveal = irev + , iDMap = computeDMap rc ik1map ir + , iA = ia + } + else return IPhase3Reject + | otherwise = return IPhase3Reject + +-------------------------- +-- Initiator Phase 4 +-------------------------- + +data IPhase4Params = IPhase4Params + { ip4pRA :: Integer + , ip4pRCommitParams :: P.CommitParams + , ip4pRK2Map :: K2Map + , ip4pRGtoK2Map :: GtoK2Map + , ip4pIK2Map :: K2Map + } + +mkIPhase4Params + :: IPhase2Priv + -> RPhase1Msg + -> RPhase3Msg + -> IPhase4Params +mkIPhase4Params ip2priv rp1msg rp3msg = + IPhase4Params + { ip4pRA = rA rp3msg + , ip4pRCommitParams = rCommitParams rp1msg + , ip4pRK2Map = rK2Map rp3msg + , ip4pRGtoK2Map = rGtoK2Map rp1msg + , ip4pIK2Map = iprivK2Map ip2priv + } + +data IPhase4Msg + = IPhase4Reject + | IPhase4Msg + { iK2Map :: K2Map + } + +iGetK2Map :: IPhase4Msg -> Maybe K2Map +iGetK2Map IPhase4Reject = Nothing +iGetK2Map (IPhase4Msg k2Map) = Just k2Map + +iPhase4 :: MonadRandom m => IPhase4Params -> SPFM m IPhase4Msg +iPhase4 (IPhase4Params ra rcp rk2map rgtok2map ik2map) + | P.verifyCommitParams ra rcp = do + gToK2Map <- kmapToGKMap rk2map + if gToK2Map == rgtok2map then + return IPhase4Msg + { iK2Map = ik2map + } + else return IPhase4Reject + | otherwise = return IPhase4Reject + +-------------------------- +-- Initiator Reveal Phase +-------------------------- + +data IPhase5Msg = IPhase5Msg + { iK1Map :: K1Map } + +iGetK1Map :: IPhase5Msg -> K1Map +iGetK1Map = iK1Map + +iPhase5 :: IPhase2Priv -> IPhase5Msg +iPhase5 ip2priv = IPhase5Msg $ iprivK1Map ip2priv + +-------------------------------------------------------------------------- + +-- Responder API + +data RPhase + = RPhase1 RPhase1Msg + | RPhase2 RPhase2Msg + | RPhase3 RPhase3Msg + | RPhase4 RPhase4Msg + +-------------------------- +-- Responder Phase 1 +-------------------------- + +data RPhase1Params = RPhase1Params + { rp1pSecurityParam :: Int + , rp1pSecretBytes :: [Word8] + , rp1pICommitParams :: P.CommitParams + } + +mkRPhase1Params :: Int -> ByteString -> IPhase1Msg -> RPhase1Params +mkRPhase1Params secParam secret ip1msg = + RPhase1Params + { rp1pSecurityParam = secParam + , rp1pSecretBytes = BA.unpack secret + , rp1pICommitParams = iCommitParams ip1msg + } + +data RPhase1Priv = RPhase1Priv + { rprivA :: Integer -- ^ Exponent such that g^rA = h (pedersen) + , rprivK1Map :: K1Map + , rprivK2Map :: K2Map + , rprivReveal :: P.Reveal + , rprivR :: Integer + } + +data RPhase1Msg = RPhase1Msg + { rCommitParams :: P.CommitParams + , rGtoK1Map :: GtoK1Map + , rGtoK2Map :: GtoK2Map + , rCommit :: P.Commitment -- ^ Commitment of private R value + } + +rPhase1 :: MonadRandom m => RPhase1Params -> SPFM m (RPhase1Priv, RPhase1Msg) +rPhase1 (RPhase1Params secParam secretBytes icp) = do + (a,commitParams) <- lift $ P.setup secParam + (k1Map,k2Map) <- genKMaps secretBytes + gtoK1Map <- kmapToGKMap k1Map + gtoK2Map <- kmapToGKMap k2Map + (r,pedersen) <- genAndCommitR icp + let rPhase1Priv = RPhase1Priv a k1Map k2Map (P.reveal pedersen) r + let rPhase1Msg = RPhase1Msg commitParams gtoK1Map gtoK2Map (P.commitment pedersen) + return (rPhase1Priv, rPhase1Msg) + +-------------------------- +-- Responder Phase 2 +-------------------------- + +data RPhase2Params = RPhase2Params + { rp2pIC :: Integer + , rp2pRK1Map :: K1Map + , rp2pRReveal :: P.Reveal + , rp2pRR :: Integer + } + +mkRPhase2Params :: RPhase1Priv -> IPhase2Msg -> RPhase2Params +mkRPhase2Params rp1priv ip2msg = + RPhase2Params + { rp2pIC = iC ip2msg + , rp2pRK1Map = rprivK1Map rp1priv + , rp2pRReveal = rprivReveal rp1priv + , rp2pRR = rprivR rp1priv + } + +data RPhase2Msg = RPhase2Msg + { rC :: Integer + , rReveal :: P.Reveal + , rDMap :: DMap + } + +rPhase2 :: MonadRandom m => RPhase2Params -> SPFM m RPhase2Msg +rPhase2 (RPhase2Params ic k1Map rreveal r) = do + c <- genC + let dmap = computeDMap ic k1Map r + return RPhase2Msg + { rC = c + , rReveal = rreveal + , rDMap = dmap + } + +-------------------------- +-- Responder Phase 3 +-------------------------- + +data RPhase3Params = RPhase3Params + { rp3pRCommitParams :: P.CommitParams + , rp3pICommitment :: P.Commitment + , rp3pIReveal :: P.Reveal + , rp3pIDMap :: DMap + , rp3pIGtoK1Map :: GtoK1Map + , rp3pRC :: Integer + , rp3pIA :: Integer + , rp3pICommitParams :: P.CommitParams + , rp3pRK2Map :: K2Map + , rp3pRA :: Integer + } + +mkRPhase3Params + :: RPhase1Priv + -> RPhase1Msg + -> RPhase2Msg + -> IPhase1Msg + -> IPhase2Msg + -> IPhase3Msg + -> RPhase3Params +mkRPhase3Params rp1priv rp1msg rp2msg ip1msg ip2msg ip3msg = + RPhase3Params + { rp3pRCommitParams = rCommitParams rp1msg + , rp3pICommitment = iCommitment ip2msg + , rp3pIReveal = iReveal ip3msg + , rp3pIDMap = iDMap ip3msg + , rp3pIGtoK1Map = iGtoK1Map ip2msg + , rp3pRC = rC rp2msg + , rp3pIA = iA ip3msg + , rp3pICommitParams = iCommitParams ip1msg + , rp3pRK2Map = rprivK2Map rp1priv + , rp3pRA = rprivA rp1priv + } + +data RPhase3Msg + = RPhase3Reject + | RPhase3Msg + { rK2Map :: K2Map + , rA :: Integer + } + +rGetK2Map :: RPhase3Msg -> K2Map +rGetK2Map = rK2Map + +rPhase3 :: MonadRandom m => RPhase3Params -> SPFM m RPhase3Msg +rPhase3 (RPhase3Params rcp icom irev idmap igtoKMap rc ia icp rK2Map ra) + | P.open rcp icom irev = do + dmapIsValid <- verifyDMap idmap igtoKMap rc (P.revealVal irev) + if dmapIsValid then + return $ RPhase3Msg rK2Map ra + else return RPhase3Reject + | otherwise = return RPhase3Reject + +-------------------------- +-- Responder Reveal Phase XXX +-------------------------- + +data RPhase4Params = RPhase4Params + { rp4pRK1Map :: K1Map + , rp4pIK2Map :: K2Map + , rp4pIGtoK2Map :: GtoK2Map + } + +mkRPhase4Params :: RPhase1Priv -> IPhase2Msg -> IPhase4Msg -> RPhase4Params +mkRPhase4Params rp1priv ip2msg ip4msg = + RPhase4Params + { rp4pRK1Map = rprivK1Map rp1priv + , rp4pIK2Map = iK2Map ip4msg + , rp4pIGtoK2Map = iGtoK2Map ip2msg + } + +-- | Final message in the protocol +data RPhase4Msg + = RPhase4Reject + | RPhase4Msg + { rK1Map :: K1Map + } + +rGetK1Map :: RPhase4Msg -> K1Map +rGetK1Map = rK1Map + +rPhase4 :: MonadRandom m => RPhase4Params -> SPFM m RPhase4Msg +rPhase4 (RPhase4Params rk1map ik2map igtok2map) = do + igtok2map' <- kmapToGKMap ik2map + if igtok2map == igtok2map' then + return $ RPhase4Msg rk1map + else return RPhase4Reject diff --git a/src/MICP/Internal.hs b/src/MICP/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MICP/Internal.hs @@ -0,0 +1,292 @@ +{-| + +Mutually Independent Commitments Protocol (MICP) + +- 1, 2(a): send pedersen bases to each other +- 2(b): Send bobGK1Map to alice +- 2(c): Send bobCommit to alice using alice params +- 3(a): Send aliceGK1Map to bob +- 3(b): Send aliceCommit to bob +- 3(c): Send aliceC to bob +- 4(a): Send bobC to alice +- 4(b): Send bobReveal to alice +- 4(c): Send bobDMap to alice +- 5(a): alice checks bob's commit +- 5(b): Send aliceReveal to bob +- 5(c): Send aliceDMap to bob +- 5(d): send alice's 'a' to bob +- 6(a): bob checks alice's commit +- 6(b): bob checks that alice's ga^a == ha +- 6(c): bob sends k'map and bob's 'a' to alice +- 7(a): alice checks that bob's ga^a == ha +- 7(b): alice checks k'map from bob matches gk'map received earlier +- 8(a): bob checks k'map from alice matches gk'map recieved earlier +- Reveal: Alice & Bob reveal KMaps + +-} +module MICP.Internal ( + MICParams, + K1Map, + K2Map, + DMap, + GtoK1Map, + GtoK2Map, + genKMaps, + kmapToGKMap, + blumMicaliPRNG, + genPRNGSeed, + genAndCommitR, + computeDMap, + mkMICParams, + genC, + verifyDMap, + micpReveal, +) where + +import Protolude +import GHC.Base (until) +import Data.List (unzip) + +import Crypto.Hash +import Crypto.Random.Types (MonadRandom(..)) + +import qualified Data.ByteArray as BA +import qualified Data.Map as Map +import Data.Maybe (fromJust) + +import qualified Pedersen as P +import PrimeField as PF + +------------------------------------------------------------------------------- +-- Blum Micali PRNG +------------------------------------------------------------------------------- + +data Bit = Zero | One + deriving (Eq, Ord, Enum, Show) + +bitsToInteger :: [Bit] -> Integer +bitsToInteger = snd . foldr accum (0,0) + where + accum :: Bit -> (Int,Integer) -> (Int,Integer) + accum b (n,total) = (n+1, total + bitToInt n b) + + bitToInt :: Int -> Bit -> Integer + bitToInt n bit + | n < 0 = 0 + | otherwise = 2^n * toInteger (fromEnum bit) + +data PRNGState = PRNGState + { i :: Int + , bits :: [Bit] + , seed :: Integer + } + +initPRNGState :: Integer -> PRNGState +initPRNGState seed = + PRNGState { i = 0 + , bits = [] + , seed = seed + } + +genPRNGSeed :: MonadRandom m => SPF -> m Integer +genPRNGSeed spf = liftM (gexpSafeSPF spf) $ randomInZp spf + +-- | Generates a hardcore bit sequence using the result from the paper: +-- "How to generate cryptographically strong sequences of pseudo random bits" +-- - M. Blum and S. Micali, 1984 +-- +-- Reference: https://crypto.stanford.edu/pbc/notes/crypto/blummicali.html +blumMicaliPRNG + :: MonadRandom m + => Int -- ^ Number of bits to generate + -> Integer -- ^ Initial seed (must be in Zp) + -> SPF -- ^ Safe prime field to compute within + -> m Integer -- ^ n-bit, pseudo-random result +blumMicaliPRNG nbits seed spf = do + let randNBits = bits $ nStepsPRNG nbits $ initPRNGState seed + return $ bitsToInteger randNBits + where + nStepsPRNG :: Int -> PRNGState -> PRNGState + nStepsPRNG n = until (\bm -> i bm == n) blumMicaliStep + + blumMicaliStep :: PRNGState -> PRNGState + blumMicaliStep (PRNGState i prevBits prevSeed) = + PRNGState { i = i + 1 + , bits = newBit : prevBits + , seed = newSeed + } + where + newSeed = blumMicaliF spf prevSeed + + newBit + | blumMicaliH spf newSeed = One + | otherwise = Zero + +-- | Strong one way function, discrete log problem: +-- f(x) = g^x mod p in some prime field Zp +blumMicaliF :: SPF -> Integer -> Integer +blumMicaliF = gexpSafeSPF + +-- | Hardcore predicate H (Blum-Micali): +-- given p from LocalParams: +-- let H(x) = if x < (p - 1)/2 then 1 else 0 +-- resource: https://crypto.stanford.edu/pbc/notes/crypto/hardcore.html +blumMicaliH :: SPF -> Integer -> Bool +blumMicaliH spf r = r < (unP (spfP spf) - 1) `div` 2 + +------------------------------------------------------------------------------- +-- Mutually Independent Commitments Protocol (MICP) +------------------------------------------------------------------------------- + +-- | Commitment parameters +data MICParams = MICParams + { secParam :: Int -- ^ Security parameter, # bits of large prime + , secretBytes :: [Word8] -- ^ Secret to commit to, as bytes + , micpSPF :: SPF -- ^ Safe Prime field (shared) + } + +mkMICParams :: Int -> ByteString -> SPF -> MICParams +mkMICParams k secret spf = + MICParams { secParam = k + , secretBytes = BA.unpack secret + , micpSPF = spf + } + +-- | Force random nums to be generated with (p,g) from shared env +-- and returns a single byte (8 random bits) as output +micpBlumMicaliPRNG :: MonadRandom m => Integer -> SPFM m Word8 +micpBlumMicaliPRNG seed = fromIntegral <$> (lift . blumMicaliPRNG 8 seed =<< ask) + +-- | Force random seed to be generated with (p,g) from shared env +micpBlumMicaliSeed :: MonadRandom m => SPFM m Integer +micpBlumMicaliSeed = lift . genPRNGSeed =<< ask + +------------------------------------------------------------------------------- +-- Generate (k,k') pairs such that H(k) XOR H(k') == secret: +------------------------------------------------------------------------------- + +type K1Map = Map Int Integer +type K2Map = Map Int Integer + +type GtoK1Map = Map Int Integer +type GtoK2Map = Map Int Integer + +-- | 2(b), 3(a): Generate two integer maps where the ith entry in +-- each map corresponds to the ith k1 and k2 values respectively such that +-- `Hn(k1_i) xor Hn(k2_i) == byte_i`. Two maps are generated map because +-- the values k and k' are to be exposed at different stages of the protocol. +genKMaps :: MonadRandom m => [Word8] -> SPFM m (K1Map,K2Map) +genKMaps bytes = do + (k1s,k2s) <- unzip <$> mapM genKPair bytes + let k1Map = Map.fromList $ zip [0..] k1s + let k2Map = Map.fromList $ zip [0..] k2s + return (k1Map,k2Map) + +-- | Generate a pair of values such that `Hn(k1) xor Hn(k2) = byte` +genKPair :: MonadRandom m => Word8 -> SPFM m (Integer,Integer) +genKPair byte = do + k1 <- micpBlumMicaliSeed + hk1 <- micpBlumMicaliPRNG k1 + k2 <- findK2 hk1 + return (k1,k2) + where + checkHKPair :: Bits a => a -> (a,a) -> Bool + checkHKPair byte (hk1,hk2) = byte == (hk1 `xor` hk2) + + findK2 :: MonadRandom m => Word8 -> SPFM m Integer + findK2 hk1 = do + k2 <- micpBlumMicaliSeed + hk2 <- micpBlumMicaliPRNG k2 + if checkHKPair byte (hk1,hk2) then + return k2 + else findK2 hk1 + +-- | Takes a Map k v and returns Map k (g^v mod p) +kmapToGKMap :: Monad m => Map Int Integer -> SPFM m (Map Int Integer) +kmapToGKMap kmap = liftM (flip map kmap . gexpSafeSPF) ask + +------------------------------------------------------------------------------- + +-- | 2(c), 3(b): Generate random r in Z_q and commit using Pedersen Commitment +genAndCommitR + :: MonadRandom m + => P.CommitParams + -> SPFM m (Integer, P.Pedersen) +genAndCommitR cparams = do + r <- randomInZqM + gr <- gexpSafeSPFM r + c <- lift $ P.commit gr cparams + return (r,c) + +-- | 3(c), 4(a): Generate random c in Z_q +genC :: MonadRandom m => SPFM m Integer +genC = randomInZqM + +------------------------------------------------------------------------------- + +type DMap = Map Int Integer + +-- | 4(c),5(c): computes d_i = c*k_i + r +computeDMap + :: Integer -- ^ Counterparty's 'c' + -> K1Map -- ^ Current party's K1Map + -> Integer -- ^ Current party's 'r' + -> DMap +computeDMap c kmap r = map computeD kmap + where + -- This function does not use modular arithmetic because the + -- exponent laws would not hold otherwise, and this is needed for + -- verification later in the protocol. For example: + -- ((x^7)^8 * (x^9) % p) /= (x^((7 * 8 + 9) % p)) % p + computeD ki = c * ki + r + +-- | 5(a), 6(a): Verifies that the counterparty has not lied about their +-- original commitment and has not tampered with the k values they used to +-- encrypt their original message: `g^d_i == (g^k_i)^c * g^r` +verifyDMap + :: Monad m + => DMap -- ^ Counterparty's DMap + -> GtoK1Map -- ^ Counterparty's (g^k, g^k') map + -> Integer -- ^ Current party's 'c' + -> Integer -- ^ Counterparty's 'g^r' + -> SPFM m Bool +verifyDMap dmap gkmap c gr = + and <$> zipWithM (verifyDi c gr) ds gks + where + ds = Map.elems dmap + gks = Map.elems gkmap + +-- | Verifies the ith `d_i` value for the ith byte of the secret +verifyDi + :: Monad m + => Integer -- ^ Current party's 'c' + -> Integer -- ^ Counterparty's 'g^r' + -> Integer -- ^ Counterparty's 'di' + -> Integer -- ^ Counterparty's 'g^ki' + -> SPFM m Bool +verifyDi c gr di gki = do + gdi <- gexpSafeSPFM di + let gkiToC = expSafeSPFM gki c + gdi' <- gkiToC |*| pure gr + return $ gdi == gdi' + +------------------------------------------------------------------------------- +-- Reveal Stage +------------------------------------------------------------------------------- + +-- | Computes the original bytestring that was commited by a counterparty once +-- they have supplied the neccessary parameters k_i and k_i'. +micpReveal :: MonadRandom m => K1Map -> K2Map -> SPFM m ByteString +micpReveal k1Map k2Map = + BA.pack <$> zipWithM (curry kpairToByte) k1s k2s + where + k1s = Map.elems k1Map + k2s = Map.elems k2Map + +-- | Generate the byte correspoding to `Hn(k) xor Hn(k')` where +-- Hn(k) is the blum-micali PRNG hardcore nbit output +kpairToByte :: MonadRandom m => (Integer,Integer) -> SPFM m Word8 +kpairToByte (k,k') = do + hk <- micpBlumMicaliPRNG k + hk' <- micpBlumMicaliPRNG k' + return $ hk `xor` hk' diff --git a/src/Pedersen.hs b/src/Pedersen.hs new file mode 100644 --- /dev/null +++ b/src/Pedersen.hs @@ -0,0 +1,257 @@ +{-| + +The Pedersen commitment scheme has three operations: + +- Setup +- Commit +- Open + +-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Pedersen ( + -- ** Safe Prime Field Pedersen Commitments + Pedersen(..), + CommitParams(..), + Commitment(..), + Reveal(..), + + setup, + commit, + open, + + addCommitments, + verifyAddCommitments, + + verifyCommitParams, + + + -- ** Elliptic Curve Pedersen Commitments + ECPedersen(..), + ECCommitParams(..), + ECCommitment(..), + ECReveal(..), + + ecSetup, + ecCommit, + ecOpen, + + ecAddCommitments, + ecVerifyAddCommitments, + ecAddInteger, + ecVerifyAddInteger, + + verifyECCommitParams + +) where + +import Protolude +import qualified Prelude + +import Crypto.Hash +import Crypto.Number.Serialize (os2ip) +import Crypto.Random.Types (MonadRandom(..)) +import qualified Crypto.PubKey.ECC.Prim as ECC +import qualified Crypto.PubKey.ECC.Types as ECC + +import Data.Bits (xor, popCount) +import qualified Data.ByteArray as BA +import qualified Data.Map as Map + +import PrimeField + +------------------------------------------------------------------------------- +-- Pedersen Commitment Scheme +------------------------------------------------------------------------------- + +data CommitParams = CommitParams + { pedersenSPF :: SPF -- ^ Safe prime field for pedersen commitment + , pedersenH :: Integer -- ^ h = g^a mod p where a is random + } + +newtype Commitment = Commitment { unCommitment :: Integer } + deriving (Eq) + +data Reveal = Reveal + { revealVal :: Integer -- ^ Original value comitted + , revealExp :: Integer -- ^ random exponent r, g^x * h^r + } + +data Pedersen = Pedersen + { commitment :: Commitment + , reveal :: Reveal + } + +-- | Generates a Safe Prime Field (p,q,g) and a random value +-- `a in Zq` such that `g^a = h`, where g and h are the bases +-- to be used in the pedersen commit function. +setup :: MonadRandom m => Int -> m (Integer, CommitParams) +setup nbits = do + spf <- mkSPF nbits + (a,h) <- runSPFT spf $ do + a <- randomInZqM + h <- gexpSafeSPFM a + return (a,h) + return (a, CommitParams spf h) + +-- | Commit a value by generating a random number `r in Zq` +-- and computing `C(x) = g^x * h^r` where x is the value to commit +commit :: MonadRandom m => Integer -> CommitParams -> m Pedersen +commit x (CommitParams spf h) = do + (r,c) <- runSPFT spf $ do + r <- randomInZqM + c <- gexpSafeSPFM x |*| expSafeSPFM h r + return (r,c) + return $ Pedersen (Commitment c) (Reveal x r) + +-- | Open the commit by supplying the value commited, `x`, the +-- random value `r` and the pedersen bases `g` and `h`, and +-- verifying that `C(x) == g^x * h^r` +open :: CommitParams -> Commitment -> Reveal -> Bool +open (CommitParams spf h) (Commitment c) (Reveal x r) = + resCommit == c + where + resCommit = runSPFM spf $ + gexpSafeSPFM x |*| expSafeSPFM h r + +-- | This addition should be recorded as the previous commits are unable +-- to be extracted from this new commitment. The only way to open this commiment +-- is to tell the committing party the two commitments that were added so that the +-- commitment can be validated and opening parameters can be created. +addCommitments :: CommitParams -> Commitment -> Commitment -> Commitment +addCommitments cp c1 c2 = Commitment $ + modp (pedersenSPF cp) $ unCommitment c1 * unCommitment c2 + +-- | This function validates a homomorphic addition of two commitments using the +-- original pedersen commits and reveals to compute the new commitment without +-- homomorphic addition. +verifyAddCommitments :: CommitParams -> Pedersen -> Pedersen -> Pedersen +verifyAddCommitments (CommitParams spf h) p1 p2 = + Pedersen newCommitment $ Reveal newVal newExp + where + (Reveal x r) = reveal p1 + (Reveal y r') = reveal p2 + + newVal = modp spf $ x + y + newExp = modp spf $ r + r' + + newCommitment = Commitment $ runSPFM spf $ + gexpSafeSPFM newVal |*| expSafeSPFM h newExp + +-- | Check that `g^a = h` to verify integrity of a counterparty's commitment +verifyCommitParams :: Integer -> CommitParams -> Bool +verifyCommitParams a (CommitParams spf h) = + runSPFM spf $ do + h' <- gexpSafeSPFM a + return $ h' == h + +------------------------------------------------------------------------------- +-- Pedersen Commitment Scheme - Elliptic Curve (SECP256k1) +------------------------------------------------------------------------------- + +secp256k1 :: ECC.Curve +secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 + +data ECCommitParams = ECCommitParams + { ecCurve :: ECC.Curve + , ecH :: ECC.Point + } + +data ECCommitment = ECCommitment { unECCommitment :: ECC.Point } + deriving Eq + +data ECReveal = ECReveal + { ecRevealVal :: Integer + , ecRevealScalar :: Integer + } + +data ECPedersen = ECPedersen + { ecCommitment :: ECCommitment + , ecReveal :: ECReveal + } + +-- | Setup EC Pedersen commit params, defaults to curve secp256k1 +ecSetup :: MonadRandom m => Maybe ECC.CurveName -> m (ECC.PrivateNumber, ECCommitParams) +ecSetup mCurveName = do + a <- ECC.scalarGenerate curve + let h = ECC.pointBaseMul curve a + return (a, ECCommitParams curve h) + where + curve = case mCurveName of + Nothing -> secp256k1 + Just cn' -> ECC.getCurveByName cn' + +ecCommit :: MonadRandom m => Integer -> ECCommitParams -> m ECPedersen +ecCommit x (ECCommitParams curve h) = do + r <- ECC.scalarGenerate curve + let xG = ECC.pointBaseMul curve x + let rH = ECC.pointMul curve r h + let commitment = ECCommitment $ ECC.pointAdd curve xG rH + let reveal = ECReveal x r + return $ ECPedersen commitment reveal + +ecOpen :: ECCommitParams -> ECCommitment -> ECReveal -> Bool +ecOpen (ECCommitParams curve h) (ECCommitment c) (ECReveal x r) = + c == ECC.pointAdd curve xG rH + where + xG = ECC.pointBaseMul curve x + rH = ECC.pointMul curve r h + +-- | In order for this resulting commitment to be opened, the commiter +-- must construct a new set of reveal parameters. The new reveal is then +-- sent to the counterparty to open the homomorphically added commitment. +ecAddCommitments + :: ECCommitParams + -> ECCommitment + -> ECCommitment + -> ECCommitment +ecAddCommitments ecp (ECCommitment c1) (ECCommitment c2) = + ECCommitment $ ECC.pointAdd (ecCurve ecp) c1 c2 + +-- | Verify the addition of two EC Pedersen Commitments by constructing +-- the new Pedersen commitment on the uncommitted values. +ecVerifyAddCommitments + :: ECCommitParams + -> ECPedersen + -> ECPedersen + -> ECPedersen +ecVerifyAddCommitments (ECCommitParams curve h) p1 p2 = + ECPedersen newCommitment newReveal + where + ECReveal x1 r1 = ecReveal p1 + ECReveal x2 r2 = ecReveal p2 + + newVal = x1 + x2 + newScalar = r1 + r2 + + xG = ECC.pointBaseMul curve newVal + rH = ECC.pointMul curve newScalar h + + newCommitment = ECCommitment $ ECC.pointAdd curve xG rH + newReveal = ECReveal newVal newScalar + +-- | Add an integer to the committed value. The committer should be informed +-- of the integer added to the commitment so that a valid pedersen reveal +-- can be constructed and the resulting commitment can be opened +ecAddInteger :: ECCommitParams -> ECCommitment -> Integer -> ECCommitment +ecAddInteger (ECCommitParams curve h) (ECCommitment c) n = + ECCommitment $ ECC.pointAdd curve nG c + where + nG = ECC.pointBaseMul curve n + +ecVerifyAddInteger :: ECCommitParams -> ECPedersen -> Integer -> ECPedersen +ecVerifyAddInteger (ECCommitParams curve h) p n = + ECPedersen newCommitment newReveal + where + ECReveal x r = ecReveal p + + newVal = x + n + + xG = ECC.pointBaseMul curve newVal + rH = ECC.pointMul curve r h -- rH doesn't change + + newCommitment = ECCommitment $ ECC.pointAdd curve xG rH + newReveal = ECReveal newVal r -- r doesn't change + +verifyECCommitParams :: Integer -> ECCommitParams -> Bool +verifyECCommitParams a (ECCommitParams curve h) = h == ECC.pointBaseMul curve a diff --git a/src/PrimeField.hs b/src/PrimeField.hs new file mode 100644 --- /dev/null +++ b/src/PrimeField.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module PrimeField ( + P, + unP, + Q, + unQ, + G, + unG, + + SPF, + spfP, + spfQ, + spfG, + mkSPF, + mkSPF', + + SPFM, + runSPFT, + runSPFM, + + gexpSafeSPF, + gexpSafeSPFM, + expSafeSPF, + expSafeSPFM, + + randomInZq, + randomInZqM, + randomInZp, + randomInZpM, + + modp, + modpM, + + (|*|), + (|+|), +)where + +import Protolude + +import Crypto.Random.Types (MonadRandom(..)) +import Crypto.Number.Generate (generateBetween) +import Crypto.Number.ModArithmetic (expSafe) +import Crypto.Number.Prime (generateSafePrime, isProbablyPrime) + +------------------------------------------------------------------------------- +-- Types for Safe Prime fields +------------------------------------------------------------------------------- + +-- | A large, safe prime, p = 2q + 1, where q is a large prime +newtype P = P { unP :: Integer } + deriving (Show, Eq, Ord) + +-- | A large prime such that p = 2q + 1 and p is also prime +newtype Q = Q { unQ :: Integer } + deriving (Show, Eq, Ord) + +-- | A generator order Q for prime field order P +newtype G = G { unG :: Integer } + deriving (Show, Eq, Ord) + +-- | A Safe Prime Field (Zp): +-- Q = large prime +-- P = 2Q + 1, also prime +-- G = generator for Zp order q +data SPF = SPF + { spfP :: P + , spfQ :: Q + , spfG :: G + } + +mkSPF :: MonadRandom m => Int -> m SPF +mkSPF nbits = do + p <- generateSafePrime nbits + let q = (p - 1) `div` 2 + g <- generateBetween 2 (q-1) + return $ SPF (P p) (Q q) (G g) + +mkSPF' :: Integer -> Integer -> Integer -> Maybe SPF +mkSPF' p g q + | isPPrime && + isQPrime && + isPSafePrime && + isGGenerator = Just $ + SPF (P p) (Q q) (G g) + | otherwise = Nothing + where + isPPrime = isProbablyPrime p + isQPrime = isProbablyPrime q + isPSafePrime = p == (2*q + 1) + isGGenerator = g > 1 && g < p + +-- | For computations using Safe Prime Field params +type SPFM = ReaderT SPF + +runSPFT :: SPF -> SPFM m a -> m a +runSPFT = flip runReaderT + +runSPFM :: SPF -> SPFM Identity a -> a +runSPFM spf = runIdentity . runSPFT spf + +------------------------------------------------------------------------------- +-- Operations in Safe Prime fields +------------------------------------------------------------------------------- + +-- | Compute g^e `mod` p +gexpSafeSPF :: SPF -> Integer -> Integer +gexpSafeSPF (SPF p _ g) e = expSafe (unG g) e (unP p) + +gexpSafeSPFM :: Monad m => Integer -> SPFM m Integer +gexpSafeSPFM e = liftM (`gexpSafeSPF` e) ask + +-- | Compute b^e `mod` p +expSafeSPF :: SPF -> Integer -> Integer -> Integer +expSafeSPF (SPF p _ _) b e = expSafe b e (unP p) + +expSafeSPFM :: Monad m => Integer -> Integer -> SPFM m Integer +expSafeSPFM b e = (\spf -> expSafeSPF spf b e) <$> ask + +-- | Generate random number in Zq +randomInZq :: MonadRandom m => SPF -> m Integer +randomInZq (SPF _ q _) = generateBetween 1 (unQ q - 1) + +randomInZqM :: MonadRandom m => SPFM m Integer +randomInZqM = lift . randomInZq =<< ask + +-- | Generate random number in Zp +randomInZp :: MonadRandom m => SPF -> m Integer +randomInZp (SPF p _ _) = generateBetween 1 (unP p - 1) + +randomInZpM :: MonadRandom m => SPFM m Integer +randomInZpM = lift . randomInZp =<< ask + +modp :: SPF -> Integer -> Integer +modp (SPF p _ _) n = n `mod` unP p + +modpM :: Monad m => Integer -> SPFM m Integer +modpM n = flip modp n <$> ask + +(|*|) :: Monad m => SPFM m Integer -> SPFM m Integer -> SPFM m Integer +x |*| y = modpM =<< liftM2 (*) x y + +(|+|) :: Monad m => SPFM m Integer -> SPFM m Integer -> SPFM m Integer +x |+| y = modpM =<< liftM2 (+) x y diff --git a/tests/Example.hs b/tests/Example.hs new file mode 100644 --- /dev/null +++ b/tests/Example.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Example ( + micpWrapper, + micpComponents, + + testPedersen, + testBlumMicaliPRNG, +) where + +import Protolude hiding (hash) + +import Control.Concurrent.MVar + +import Crypto.Hash +import Crypto.Number.Serialize (os2ip) +import Crypto.Random.Types (MonadRandom(..)) + +import qualified Data.ByteArray as BA +import Data.Maybe (fromJust) + +import MICP +import MICP.Internal +import Pedersen +import PrimeField + +testBlumMicaliPRNG :: IO Integer +testBlumMicaliPRNG = do + let k = 256 + (a,cparams) <- setup k + let spf = pedersenSPF cparams + seed <- genPRNGSeed spf + blumMicaliPRNG k seed spf + +testPedersen :: ByteString -> IO Bool +testPedersen bs = do + let hashedBs = os2ip $ sha256 bs + (a,commitParams) <- setup 256 -- hashStorage uses sha256 + (Pedersen c r) <- commit hashedBs commitParams + return $ open commitParams c r + +-- | This example illustrates how you might implement the server logic for two +-- parties to use MICP in a distributed network. MVars are used to simulate +-- message passing, but can be replaced with any message passing construct. +-- Note: this example does not handle Reject messages properly. +micpWrapper :: Int -> IO Bool +micpWrapper nbits = do + + -- MVars for message passing between I and R + iMVar <- newEmptyMVar + rMVar <- newEmptyMVar + -- MVars for MICP thread reporting result + iResMVar <- newEmptyMVar + rResMVar <- newEmptyMVar + + let aliceSecret = sha256 "123456789" + let bobSecret = sha256 "987654321" + + -- Generate shared Safe Prime Field + spf <- mkSPF nbits + forkIO $ void $ runSPFT spf $ -- Alice thread + alice aliceSecret iMVar rMVar iResMVar + forkIO $ void $ runSPFT spf $ -- Bob thread + bob bobSecret rMVar iMVar rResMVar + + -- Each party should have computed each other's secret + iRes <- takeMVar iResMVar + rRes <- takeMVar rResMVar + + return $ iRes == bobSecret && rRes == aliceSecret + where + alice + :: ByteString + -> MVar IPhase + -> MVar RPhase + -> MVar ByteString + -> SPFM IO () + alice secret ipMVar rpMVar resMVar = do + + -- Phase 1 + (ip1priv, ip1Msg) <- lift $ iPhase1 nbits + liftIO $ putMVar ipMVar $ IPhase1 ip1Msg + (RPhase1 rp1msg) <- liftIO $ takeMVar rpMVar + + -- Phase 2 + let ip2params = mkIPhase2Params secret rp1msg + (ip2priv, ip2Msg) <- iPhase2 ip2params + liftIO $ putMVar ipMVar $ IPhase2 ip2Msg + (RPhase2 rp2msg) <- liftIO $ takeMVar rpMVar + + -- Phase 3 (Should case match on rp3msg for RPhase3Reject) + let ip3params = mkIPhase3Params ip1priv ip1Msg ip2priv ip2Msg rp1msg rp2msg + ip3Msg <- iPhase3 ip3params + liftIO $ putMVar ipMVar $ IPhase3 ip3Msg + (RPhase3 rp3msg) <- liftIO $ takeMVar rpMVar + + -- Phase 4 (Should case match on rp4msg for RPhase4Reject) + let ip4params = mkIPhase4Params ip2priv rp1msg rp3msg + ip4Msg <- iPhase4 ip4params + liftIO $ putMVar ipMVar $ IPhase4 ip4Msg + (RPhase4 rp4msg) <- liftIO $ takeMVar rpMVar + + -- Phase 5 + let ip5Msg = iPhase5 ip2priv + liftIO $ putMVar ipMVar $ IPhase5 ip5Msg + + -- Compute bob's secret + let k1Map = rGetK1Map rp4msg + let k2Map = rGetK2Map rp3msg + rSecret <- micpReveal k1Map k2Map + + liftIO $ putMVar resMVar rSecret + + bob + :: ByteString + -> MVar RPhase + -> MVar IPhase + -> MVar ByteString + -> SPFM IO () + bob secret rpMVar ipMVar resMVar = do + + -- Phase 1 + (IPhase1 ip1msg) <- liftIO $ takeMVar ipMVar + let rp1params = mkRPhase1Params nbits secret ip1msg + (rp1priv, rp1Msg) <- rPhase1 rp1params + liftIO $ putMVar rpMVar $ RPhase1 rp1Msg + + -- Phase 2 + (IPhase2 ip2msg) <- liftIO $ takeMVar ipMVar + let rp2params = mkRPhase2Params rp1priv ip2msg + rp2Msg <- rPhase2 rp2params + liftIO $ putMVar rpMVar $ RPhase2 rp2Msg + + -- Phase 3 (Should case match on ip3msg for IPhase3Reject) + (IPhase3 ip3msg) <- liftIO $ takeMVar ipMVar + case ip3msg of + IPhase3Reject -> panic "IPhase3Reject" + _ -> do + let rp3params = mkRPhase3Params rp1priv rp1Msg rp2Msg ip1msg ip2msg ip3msg + rp3Msg <- rPhase3 rp3params + liftIO $ putMVar rpMVar $ RPhase3 rp3Msg + + -- Phase 4 (Should case match on ip4msg for IPhase4Reject) + (IPhase4 ip4msg) <- liftIO $ takeMVar ipMVar + let rp4params = mkRPhase4Params rp1priv ip2msg ip4msg + rp4Msg <- rPhase4 rp4params + liftIO $ putMVar rpMVar $ RPhase4 rp4Msg + + -- Phase 5 + (IPhase5 ip5msg) <- liftIO $ takeMVar ipMVar + + -- Compute Alice's secret + let k1Map = iGetK1Map ip5msg + let k2Map = fromJust $ iGetK2Map ip4msg + aliceSecret <- micpReveal k1Map k2Map + + liftIO $ putMVar resMVar aliceSecret + +-- | In this test, all values computed are in scope for both Alice & Bob, so +-- instead of "sending" those values to one another, we can just use them for +-- the respective counterparty computations. +micpComponents :: Int -> IO Bool +micpComponents secParam = do + let aliceMsg = sha256 "123456789" + let aliceMsgBytes = BA.unpack aliceMsg + let bobMsg = sha256 "987654321" + let bobMsgBytes = BA.unpack bobMsg + + putText "\nCreating Shared SPF and Local Params..." + sharedSPF <- mkSPF secParam + + -- 1, 2(a): send pedersen bases to each other + (aliceA, aCommitParams) <- setup secParam + (bobA, bCommitParams) <- setup secParam + + -- All further computation takes places in SPF + runSPFT sharedSPF $ do + + -- 2(b): Send bobGKMap to alice + putText "Gen bob kmap" + (bobKMap,bobK'Map) <- genKMaps bobMsgBytes + bobGtoKMap <- kmapToGKMap bobKMap + bobGtoK'Map <- kmapToGKMap bobK'Map + + -- 2(c): Send bobCommit to alice using alice params + putText "Gen bob r" + (bobR, bobPedersen) <- genAndCommitR aCommitParams + let (Pedersen bobCommitment bobReveal) = bobPedersen + + -- 3(a): Send aliceGKMap to bob + putText "Gen alice kmap" + (aliceKMap, aliceK'Map) <- genKMaps aliceMsgBytes + aliceGtoKMap <- kmapToGKMap aliceKMap + aliceGtoK'Map <- kmapToGKMap aliceK'Map + + -- 3(b): Send aliceCommit to bob + putText "Gen alice r" + (aliceR, alicePedersen) <- genAndCommitR bCommitParams + let (Pedersen aliceCommitment aliceReveal) = alicePedersen + + -- 3(c): Send aliceC to bob + putText "Gen alice c" + aliceC <- genC + + -- 4(a): Send bobC to alice + putText "Gen bob c" + bobC <- genC + + -- 4(b): Send bobReveal to alice + + -- 4(c): Send bobDMap to alice + putText "Compute bob dmap" + let bobDMap = computeDMap aliceC bobKMap bobR + + -- 5(a): alice checks bob's commit + unless (open aCommitParams bobCommitment bobReveal) $ + panic "Bob's commit is illegitimate!" + -- alice verifies g^di = (g^ki)^c + g^r + bobDMapVerified <- verifyDMap bobDMap bobGtoKMap aliceC $ revealVal bobReveal + unless bobDMapVerified $ + panic "Bob's computations are wrong!" + + -- 5(b): Send aliceReveal to bob + + -- 5(c): Send aliceDMap to bob + putText "Compute alice dmap" + let aliceDMap = computeDMap bobC aliceKMap aliceR + + -- 5(d): send alice's 'a' to bob + + -- 6(a): bob checks alice's commit + unless (open bCommitParams aliceCommitment aliceReveal) $ + panic "Alice's commit is illegitimate!" + -- bob verifies g^di = (g^ki)^c + g^r + aliceDMapVerified <- verifyDMap aliceDMap aliceGtoKMap bobC $ revealVal aliceReveal + unless aliceDMapVerified $ + panic "Alice's computations are wrong!" + + -- 6(b): bob checks that alice's ga^a == ha + unless (verifyCommitParams aliceA aCommitParams) $ + panic "Alice's pedersen bases are not valid!" + + -- 6(c): bob sends k'map and bob's 'a' to alice + + -- 7(a): alice checks that bob's ga^a == ha + unless (verifyCommitParams bobA bCommitParams) $ + panic "Bob's pedersen bases are not valid!" + + -- 7(b): alice checks k'map from bob matches gk'map received earlier + bobGtoK'MapCheck <- kmapToGKMap bobK'Map + unless (bobGtoK'MapCheck == bobGtoK'Map) $ + panic "Bob's k' and gk' maps are invalid!" + + -- 7(c): alice sends k'map to bob + + -- 8(a): bob checks k'map from alice matches gk'map recieved earlier + aliceGtoK'MapCheck <- kmapToGKMap aliceK'Map + unless (aliceGtoK'MapCheck == aliceGtoK'Map) $ + panic "Alice's k' and gk' maps are invalid!" + + -- REVEAL STAGE: + -- Alice & Bob reveal kMaps (map of k only, no k') + + -- Using bob/alice env respectively to show this reveal can happen within + -- the shared env only, and doesn't care about local pedersen params + aliceMsgRes <- micpReveal aliceKMap aliceK'Map + let aliceResEqMsg = aliceMsgRes == aliceMsg + bobMsgRes <- micpReveal bobKMap bobK'Map + let bobResEqMsg = bobMsgRes == bobMsg + + return $ aliceResEqMsg && bobResEqMsg + +sha256 :: ByteString -> ByteString +sha256 bs = BA.convert (hash bs :: Digest SHA3_256) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Main ( + main, +) where + +import Protolude + +import qualified Crypto.PubKey.ECC.Prim as ECC + +import Test.Tasty +import Test.Tasty.HUnit as HU +import Test.Tasty.QuickCheck +import Test.QuickCheck.Monadic as QM + +import Example (micpWrapper, micpComponents) + +import Pedersen +import PrimeField + +suite :: TestTree +suite = testGroup "Test Suite" [ + testGroup "Units" + [ pedersenTests + , micpTests + ] + ] + +pedersenTests :: TestTree +pedersenTests = testGroup "Pedersen Commitment Scheme" + [ localOption (QuickCheckTests 50) $ + testProperty "x == Open(Commit(x),r)" $ monadicIO $ do + (a, cp) <- liftIO $ setup 256 + x <- liftIO $ randomInZq $ pedersenSPF cp + pc <- liftIO $ commit x cp + QM.assert $ open cp (commitment pc) (reveal pc) + + , testCaseSteps "Additive Homomorphic Commitments" $ \step -> do + step "Generating commit params..." + (a,cp) <- setup 256 + let spf = pedersenSPF cp + + step "Generating two random numbers in Zp to commit..." + x <- randomInZq spf + y <- randomInZq spf + + step "Committing the two random numbers..." + px@(Pedersen cx rx) <- commit x cp + py@(Pedersen cy ry) <- commit y cp + + step "Verifying Additive Homomorphic property..." + let cz = addCommitments cp cx cy + let pz = verifyAddCommitments cp px py + assertAddHomo $ cz == commitment pz + + , testProperty "x == Open(Commit(x),r) (EC) " $ + monadicIO $ do + (a,cp) <- liftIO $ ecSetup Nothing -- uses SECP256k1 by default + x <- liftIO $ ECC.scalarGenerate $ ecCurve cp + pc <- liftIO $ ecCommit x cp + QM.assert $ ecOpen cp (ecCommitment pc) (ecReveal pc) + + , testCaseSteps "Additive Homomorphic Commitments (EC) " $ \step -> do + step "Generating commit params..." + (a,ecp) <- ecSetup Nothing + let curve = ecCurve ecp + + step "Generating two random numbers in Ep (EC prime field order q)..." + x <- ECC.scalarGenerate curve + y <- ECC.scalarGenerate curve + + step "Committing the two random numbers..." + px@(ECPedersen cx rx) <- ecCommit x ecp + py@(ECPedersen cy ry) <- ecCommit y ecp + + step "Verifying Additive Homomorphic property..." + let cz = ecAddCommitments ecp cx cy + let pz = ecVerifyAddCommitments ecp px py + assertAddHomo $ cz == ecCommitment pz + + , testCaseSteps "Additive Homomorphic property (EC) | nG + C(x) == (x + n)G + rH" $ \step -> do + step "Generating commit params..." + (a,ecp) <- ecSetup Nothing + let curve = ecCurve ecp + + step "Generating a random number to commit..." + x <- ECC.scalarGenerate curve + step "Committing the the random number..." + px@(ECPedersen cx rx) <- ecCommit x ecp + + step "Generating a random number to add to the commitment..." + n <- ECC.scalarGenerate curve + + step "Verifying the Additive homomorphic property" + let cy = ecAddInteger ecp cx n + let py = ecVerifyAddInteger ecp px n + assertAddHomo $ cy == ecCommitment py + + ] + where + assertAddHomo :: Bool -> IO () + assertAddHomo = assertBool "Additive homomorphic property doesn't hold." + +micpTests :: TestTree +micpTests = testGroup "Mutually Independent Commitment Protocol" + [ testCase "Testing MICP Components" $ + assertBool "MICP Components test failed!" =<< micpComponents 256 + , testCase "Testing MICP Wrapper" $ + assertBool "MICP Wrapper test failed!" =<< micpWrapper 256 + ] + +main :: IO () +main = defaultMain suite