packages feed

pedersen-commitment (empty) → 0.1.0

raw patch · 9 files changed

+1763/−0 lines, 9 filesdep +QuickCheckdep +basedep +bytestring

Dependencies added: QuickCheck, base, bytestring, containers, cryptonite, memory, mtl, pedersen-commitment, protolude, tasty, tasty-hunit, tasty-quickcheck, text

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,133 @@+<p align="center">+  <a href="http://www.adjoint.io"><img src="https://www.adjoint.io/images/logo-small.png" width="250"/></a>+</p>++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.+```+
+ pedersen-commitment.cabal view
@@ -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
+ src/MICP.hs view
@@ -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
+ src/MICP/Internal.hs view
@@ -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'
+ src/Pedersen.hs view
@@ -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
+ src/PrimeField.hs view
@@ -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
+ tests/Example.hs view
@@ -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)
+ tests/Main.hs view
@@ -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