diff --git a/benchmarks/Election.hs b/benchmarks/Election.hs --- a/benchmarks/Election.hs +++ b/benchmarks/Election.hs @@ -13,7 +13,7 @@ makeElection :: forall crypto v c. Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => JSON.ToJSON crypto => Int -> Int -> Election crypto v c @@ -47,7 +47,7 @@ makeBallot :: Reifies v Version => - GroupParams crypto c => Key crypto => + CryptoParams crypto c => Key crypto => Election crypto v c -> Ballot crypto v c makeBallot elec = case runExcept $ (`evalStateT` mkStdGen seed) $ do @@ -69,7 +69,7 @@ benchEncryptBallot :: forall crypto v c. - GroupParams crypto c => + CryptoParams crypto c => Reifies v Version => Key crypto => JSON.ToJSON crypto => @@ -86,7 +86,7 @@ benchVerifyBallot :: forall crypto v c. Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => JSON.ToJSON crypto => NFData crypto => diff --git a/hjugement-protocol.cabal b/hjugement-protocol.cabal --- a/hjugement-protocol.cabal +++ b/hjugement-protocol.cabal @@ -2,7 +2,7 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.9.20191031 +version: 0.0.10.20191104 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: @@ -61,14 +61,16 @@ hs-source-dirs: src exposed-modules: Voting.Protocol - Voting.Protocol.Arith + Voting.Protocol.Arithmetic Voting.Protocol.Credential + Voting.Protocol.Cryptography Voting.Protocol.Election Voting.Protocol.FFC Voting.Protocol.Tally Voting.Protocol.Trustee Voting.Protocol.Trustee.Indispensable Voting.Protocol.Utils + Voting.Protocol.Version default-language: Haskell2010 default-extensions: AllowAmbiguousTypes diff --git a/src/Voting/Protocol.hs b/src/Voting/Protocol.hs --- a/src/Voting/Protocol.hs +++ b/src/Voting/Protocol.hs @@ -1,22 +1,26 @@ module Voting.Protocol - ( module Voting.Protocol.Arith - , module Voting.Protocol.FFC + ( module Voting.Protocol.Arithmetic + , module Voting.Protocol.Version + , module Voting.Protocol.Cryptography , module Voting.Protocol.Credential , module Voting.Protocol.Election , module Voting.Protocol.Tally , module Voting.Protocol.Trustee + , module Voting.Protocol.FFC , Natural , RandomGen , Reifies(..), reify , Proxy(..) ) where -import Voting.Protocol.Arith -import Voting.Protocol.FFC +import Voting.Protocol.Arithmetic +import Voting.Protocol.Cryptography +import Voting.Protocol.Version import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally import Voting.Protocol.Trustee +import Voting.Protocol.FFC import Data.Proxy (Proxy(..)) import Data.Reflection (Reifies(..), reify) diff --git a/src/Voting/Protocol/Arith.hs b/src/Voting/Protocol/Arith.hs deleted file mode 100644 --- a/src/Voting/Protocol/Arith.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto -{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | Arithmetic -module Voting.Protocol.Arith where - -import Control.Arrow (first) -import Control.DeepSeq (NFData) -import Control.Monad (Monad(..)) -import Data.Aeson (ToJSON(..),FromJSON(..)) -import Data.Bits -import Data.Bool -import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldl') -import Data.Function (($), (.), id) -import Data.Functor ((<$>)) -import Data.Int (Int) -import Data.Maybe (Maybe(..), fromJust) -import Data.Ord (Ord(..)) -import Data.Proxy (Proxy(..)) -import Data.Reflection (Reifies(..)) -import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import GHC.Natural (minusNaturalMaybe) -import Numeric.Natural (Natural) -import Prelude (Integer, Integral(..), fromIntegral, Enum(..)) -import Text.Read (readMaybe) -import Text.Show (Show(..)) -import qualified Control.Monad.Trans.State.Strict as S -import qualified Crypto.Hash as Crypto -import qualified Data.Aeson as JSON -import qualified Data.Aeson.Types as JSON -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as BS64 -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Builder.Int as TLB -import qualified Prelude as Num -import qualified System.Random as Random - --- * Class 'Additive' -class Additive a where - zero :: a - (+) :: a -> a -> a; infixl 6 + - sum :: Foldable f => f a -> a - sum = foldl' (+) zero -instance Additive Natural where - zero = 0 - (+) = (Num.+) -instance Additive Integer where - zero = 0 - (+) = (Num.+) -instance Additive Int where - zero = 0 - (+) = (Num.+) - --- ** Class 'Negable' -class Additive a => Negable a where - neg :: a -> a - (-) :: a -> a -> a; infixl 6 - - x-y = x + neg y -instance Negable Integer where - neg = Num.negate -instance Negable Int where - neg = Num.negate - --- * Class 'Multiplicative' -class Multiplicative a where - one :: a - (*) :: a -> a -> a; infixl 7 * -instance Multiplicative Natural where - one = 1 - (*) = (Num.*) -instance Multiplicative Integer where - one = 1 - (*) = (Num.*) -instance Multiplicative Int where - one = 1 - (*) = (Num.*) - --- ** Class 'Invertible' -class Multiplicative a => Invertible a where - inv :: a -> a - (/) :: a -> a -> a; infixl 7 / - x/y = x * inv y - --- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'. -(^) :: - forall crypto c. - Reifies c crypto => - Multiplicative (G crypto c) => - G crypto c -> E crypto c -> G crypto c -(^) b (E e) - | e == 0 = one - | otherwise = t * (b*b) ^ E (e`shiftR`1) - where t | testBit e 0 = b - | otherwise = one -infixr 8 ^ - --- * Class 'GroupParams' where -class - ( Multiplicative (G crypto c) - , Invertible (G crypto c) - , FromNatural (G crypto c) - , ToNatural (G crypto c) - , Eq (G crypto c) - , Ord (G crypto c) - , Show (G crypto c) - , NFData (G crypto c) - , FromJSON (G crypto c) - , ToJSON (G crypto c) - , Reifies c crypto - ) => GroupParams crypto c where - -- | A generator of the subgroup. - groupGen :: G crypto c - -- | The order of the subgroup. - groupOrder :: Proxy c -> Natural - - -- | 'groupGenPowers' returns the infinite list - -- of powers of 'groupGen'. - -- - -- NOTE: In the 'GroupParams' class to keep - -- computed values in memory across calls to 'groupGenPowers'. - groupGenPowers :: [G crypto c] - groupGenPowers = go one - where go g = g : go (g * groupGen) - - -- | 'groupGenInverses' returns the infinite list - -- of 'inv'erse powers of 'groupGen': - -- @['groupGen' '^' 'neg' i | i <- [0..]]@, - -- but by computing each value from the previous one. - -- - -- NOTE: In the 'GroupParams' class to keep - -- computed values in memory across calls to 'groupGenInverses'. - -- - -- Used by 'intervalDisjunctions'. - groupGenInverses :: [G crypto c] - groupGenInverses = go one - where - invGen = inv $ groupGen - go g = g : go (g * invGen) - --- ** Class 'ReifyCrypto' -class ReifyCrypto crypto where - -- | Like 'reify' but augmented with the 'GroupParams' constraint. - reifyCrypto :: crypto -> (forall c. Reifies c crypto => GroupParams crypto c => Proxy c -> r) -> r - --- ** Type 'G' --- | The type of the elements of a subgroup of a field. -newtype G crypto c = G { unG :: FieldElement crypto } - --- *** Type family 'FieldElement' -type family FieldElement crypto :: * - --- ** Type 'E' --- | An exponent of a (cyclic) subgroup of a field. --- The value is always in @[0..'groupOrder'-1]@. -newtype E crypto c = E { unE :: Natural } - deriving (Eq,Ord,Show) - deriving newtype NFData -instance ToJSON (E crypto c) where - toJSON = JSON.toJSON . show . unE -instance GroupParams crypto c => FromJSON (E crypto c) where - parseJSON (JSON.String s) - | Just (c0,_) <- Text.uncons s - , c0 /= '0' - , Text.all Char.isDigit s - , Just x <- readMaybe (Text.unpack s) - , x < groupOrder (Proxy @c) - = return (E x) - parseJSON json = JSON.typeMismatch "Exponent" json -instance GroupParams crypto c => FromNatural (E crypto c) where - fromNatural i = - E $ abs $ i `mod` groupOrder (Proxy @c) - where - abs x | x < 0 = x + groupOrder (Proxy @c) - | otherwise = x -instance ToNatural (E crypto c) where - nat = unE -instance GroupParams crypto c => Additive (E crypto c) where - zero = E zero - E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c) -instance GroupParams crypto c => Negable (E crypto c) where - neg (E x) - | x == 0 = zero - | otherwise = E $ fromJust $ nat (groupOrder (Proxy @c))`minusNaturalMaybe`x -instance GroupParams crypto c => Multiplicative (E crypto c) where - one = E one - E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c) -instance GroupParams crypto c => Random.Random (E crypto c) where - randomR (E lo, E hi) = - first (E . fromIntegral) . - Random.randomR - ( 0`max`toInteger lo - , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) ) - random = - first (E . fromIntegral) . - Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1) -instance GroupParams crypto c => Enum (E crypto c) where - toEnum = fromNatural . fromIntegral - fromEnum = fromIntegral . nat - enumFromTo lo hi = List.unfoldr - (\i -> if i<=hi then Just (i, i+one) else Nothing) lo - --- * Class 'FromNatural' -class FromNatural a where - fromNatural :: Natural -> a - --- * Class 'ToNatural' -class ToNatural a where - nat :: a -> Natural -instance ToNatural Natural where - nat = id - --- | @('bytesNat' x)@ returns the serialization of 'x'. -bytesNat :: ToNatural n => n -> BS.ByteString -bytesNat = fromString . show . nat - --- * Type 'Hash' -newtype Hash crypto c = Hash (E crypto c) - deriving newtype (Eq,Ord,Show,NFData) - --- | @('hash' bs gs)@ returns as a number in 'GroupExponent' --- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs' --- prefixing the decimal representation of given subgroup elements 'gs', --- with a comma (",") intercalated between them. --- --- NOTE: to avoid any collision when the 'hash' function is used in different contexts, --- a message 'gs' is actually prefixed by a 'bs' indicating the context. --- --- Used by 'proveEncryption' and 'verifyEncryption', --- where the 'bs' usually contains the 'statement' to be proven, --- and the 'gs' contains the 'commitments'. -hash :: GroupParams crypto c => BS.ByteString -> [G crypto c] -> E crypto c -hash bs gs = do - let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs) - let h = Crypto.hashWith Crypto.SHA256 s - fromNatural $ - decodeBigEndian $ ByteArray.convert h - --- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number. -decodeBigEndian :: BS.ByteString -> Natural -decodeBigEndian = - BS.foldl' - (\acc b -> acc`shiftL`8 + fromIntegral b) - (0::Natural) - --- ** Type 'Base64SHA256' -newtype Base64SHA256 = Base64SHA256 Text - deriving (Eq,Ord,Show,Generic) - deriving anyclass (ToJSON,FromJSON) - deriving newtype NFData - --- | @('base64SHA256' bs)@ returns the 'Crypto.SHA256' hash --- of the given 'BS.ByteString' 'bs', --- as a 'Text' escaped in @base64@ encoding --- (). -base64SHA256 :: BS.ByteString -> Base64SHA256 -base64SHA256 bs = - let h = Crypto.hashWith Crypto.SHA256 bs in - Base64SHA256 $ - Text.takeWhile (/= '=') $ -- NOTE: no padding. - Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h - --- ** Type 'HexSHA256' -newtype HexSHA256 = HexSHA256 Text - deriving (Eq,Ord,Show,Generic) - deriving anyclass (ToJSON,FromJSON) - deriving newtype NFData --- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash --- of the given 'BS.ByteString' 'bs', escaped in hexadecimal --- into a 'Text' of 32 lowercase characters. --- --- Used (in retro-dependencies of this library) to hash --- the 'PublicKey' of a voter or a trustee. -hexSHA256 :: BS.ByteString -> Text -hexSHA256 bs = - let h = Crypto.hashWith Crypto.SHA256 bs in - let n = decodeBigEndian $ ByteArray.convert h in - -- NOTE: always set the 256 bit then remove it - -- to always have leading zeros, - -- and thus always 64 characters wide hashes. - TL.toStrict $ - TL.tail $ TLB.toLazyText $ TLB.hexadecimal $ - setBit n 256 - --- * Random - --- | @('randomR' i)@ returns a random integer in @[0..i-1]@. -randomR :: - Monad m => - Random.RandomGen r => - Random.Random i => - Negable i => - Multiplicative i => - i -> S.StateT r m i -randomR i = S.StateT $ return . Random.randomR (zero, i-one) - --- | @('random')@ returns a random integer --- in the range determined by its type. -random :: - Monad m => - Random.RandomGen r => - Random.Random i => - Negable i => - Multiplicative i => - S.StateT r m i -random = S.StateT $ return . Random.random - -instance Random.Random Natural where - randomR (mini,maxi) = - first (fromIntegral::Integer -> Natural) . - Random.randomR (fromIntegral mini, fromIntegral maxi) - random = first (fromIntegral::Integer -> Natural) . Random.random diff --git a/src/Voting/Protocol/Arithmetic.hs b/src/Voting/Protocol/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Voting/Protocol/Arithmetic.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto +module Voting.Protocol.Arithmetic where + +import Control.Arrow (first) +import Control.DeepSeq (NFData) +import Control.Monad (Monad(..)) +import Data.Aeson (ToJSON(..),FromJSON(..)) +import Data.Bits +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable, foldl') +import Data.Function (($), (.), id) +import Data.Int (Int) +import Data.Maybe (Maybe(..), fromJust) +import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..)) +import Data.String (IsString(..)) +import GHC.Natural (minusNaturalMaybe) +import Numeric.Natural (Natural) +import Prelude (Integer, Bounded(..), Integral(..), fromIntegral, Enum(..)) +import Text.Read (readMaybe) +import Text.Show (Show(..)) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types as JSON +import qualified Data.ByteString as BS +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Prelude as Num +import qualified System.Random as Random + +-- * Class 'CryptoParams' where +class + ( EuclideanRing (G crypto c) + , FromNatural (G crypto c) + , ToNatural (G crypto c) + , Eq (G crypto c) + , Ord (G crypto c) + , Show (G crypto c) + , NFData (G crypto c) + , FromJSON (G crypto c) + , ToJSON (G crypto c) + , Reifies c crypto + ) => CryptoParams crypto c where + -- | A generator of the subgroup. + groupGen :: G crypto c + -- | The order of the subgroup. + groupOrder :: Proxy c -> Natural + + -- | 'groupGenPowers' returns the infinite list + -- of powers of 'groupGen'. + -- + -- NOTE: In the 'CryptoParams' class to keep + -- computed values in memory across calls to 'groupGenPowers'. + groupGenPowers :: [G crypto c] + groupGenPowers = go one + where go g = g : go (g * groupGen) + + -- | 'groupGenInverses' returns the infinite list + -- of 'inverse' powers of 'groupGen': + -- @['groupGen' '^' 'negate' i | i <- [0..]]@, + -- but by computing each value from the previous one. + -- + -- NOTE: In the 'CryptoParams' class to keep + -- computed values in memory across calls to 'groupGenInverses'. + -- + -- Used by 'intervalDisjunctions'. + groupGenInverses :: [G crypto c] + groupGenInverses = go one + where + invGen = inverse groupGen + go g = g : go (g * invGen) + +-- ** Class 'ReifyCrypto' +class ReifyCrypto crypto where + -- | Like 'reify' but augmented with the 'CryptoParams' constraint. + reifyCrypto :: crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r + +-- * Class 'Additive' +-- | An additive semigroup. +class Additive a where + zero :: a + (+) :: a -> a -> a; infixl 6 + + sum :: Foldable f => f a -> a + sum = foldl' (+) zero +instance Additive Natural where + zero = 0 + (+) = (Num.+) +instance Additive Integer where + zero = 0 + (+) = (Num.+) +instance Additive Int where + zero = 0 + (+) = (Num.+) + +-- * Class 'Semiring' +-- | A multiplicative semigroup, with an additive semigroup (aka. a semiring). +class Additive a => Semiring a where + one :: a + (*) :: a -> a -> a; infixl 7 * +instance Semiring Natural where + one = 1 + (*) = (Num.*) +instance Semiring Integer where + one = 1 + (*) = (Num.*) +instance Semiring Int where + one = 1 + (*) = (Num.*) + +-- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'. +(^) :: + forall crypto c. + Reifies c crypto => + Semiring (G crypto c) => + G crypto c -> E crypto c -> G crypto c +(^) b (E e) + | e == 0 = one + | otherwise = t * (b*b) ^ E (e`shiftR`1) + where t | testBit e 0 = b + | otherwise = one +infixr 8 ^ + +-- ** Class 'Ring' +-- | A semiring that support substraction (aka. a ring). +class Semiring a => Ring a where + negate :: a -> a + (-) :: a -> a -> a; infixl 6 - + x-y = x + negate y +instance Ring Integer where + negate = Num.negate +instance Ring Int where + negate = Num.negate + +-- ** Class 'EuclideanRing' +-- | A commutative ring that support division (aka. an euclidean ring). +class Ring a => EuclideanRing a where + inverse :: a -> a + (/) :: a -> a -> a; infixl 7 / + x/y = x * inverse y + +-- ** Type 'G' +-- | The type of the elements of a subgroup of a field. +newtype G crypto c = G { unG :: FieldElement crypto } + +-- *** Type family 'FieldElement' +type family FieldElement crypto :: * + +-- ** Type 'E' +-- | An exponent of a (cyclic) subgroup of a field. +-- The value is always in @[0..'groupOrder'-1]@. +newtype E crypto c = E { unE :: Natural } + deriving (Eq,Ord,Show) + deriving newtype NFData +instance ToJSON (E crypto c) where + toJSON = JSON.toJSON . show . unE +instance CryptoParams crypto c => FromJSON (E crypto c) where + parseJSON (JSON.String s) + | Just (c0,_) <- Text.uncons s + , c0 /= '0' + , Text.all Char.isDigit s + , Just x <- readMaybe (Text.unpack s) + , x < groupOrder (Proxy @c) + = return (E x) + parseJSON json = JSON.typeMismatch "Exponent" json +instance CryptoParams crypto c => FromNatural (E crypto c) where + fromNatural n = E $ n `mod` groupOrder (Proxy @c) +instance ToNatural (E crypto c) where + nat = unE +instance CryptoParams crypto c => Additive (E crypto c) where + zero = E zero + E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c) +instance CryptoParams crypto c => Semiring (E crypto c) where + one = E one + E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c) +instance CryptoParams crypto c => Ring (E crypto c) where + negate (E x) = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`x +instance CryptoParams crypto c => Random.Random (E crypto c) where + randomR (E lo, E hi) = + first (E . fromIntegral) . + Random.randomR + ( 0`max`toInteger lo + , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) ) + random = + first (E . fromIntegral) . + Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1) +instance CryptoParams crypto c => Enum (E crypto c) where + toEnum = fromNatural . fromIntegral + fromEnum = fromIntegral . nat + enumFromTo lo hi = List.unfoldr + (\i -> if i<=hi then Just (i, i+one) else Nothing) lo +instance CryptoParams crypto c => Bounded (E crypto c) where + minBound = zero + maxBound = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`1 + +-- * Class 'FromNatural' +class FromNatural a where + fromNatural :: Natural -> a +instance FromNatural Natural where + fromNatural = id + +-- * Class 'ToNatural' +class ToNatural a where + nat :: a -> Natural +instance ToNatural Natural where + nat = id + +-- | @('bytesNat' x)@ returns the serialization of 'x'. +bytesNat :: ToNatural n => n -> BS.ByteString +bytesNat = fromString . show . nat diff --git a/src/Voting/Protocol/Credential.hs b/src/Voting/Protocol/Credential.hs --- a/src/Voting/Protocol/Credential.hs +++ b/src/Voting/Protocol/Credential.hs @@ -28,7 +28,8 @@ import qualified Data.Text as Text import qualified System.Random as Random -import Voting.Protocol.Arith +import Voting.Protocol.Arithmetic +import Voting.Protocol.Cryptography -- * Class 'Key' class Key crypto where @@ -54,11 +55,6 @@ SecretKey crypto c -> PublicKey crypto c --- ** Type 'PublicKey' -type PublicKey = G --- ** Type 'SecretKey' -type SecretKey = E - -- * Type 'Credential' -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters -- from a base alphabet of (@'tokenBase' '==' 58)@ characters: @@ -91,7 +87,7 @@ ( acc * tokenBase + d , charOfDigit d : ds ) ) (zero::Int, []) rs - let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ? + let checksum = (negate tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ? return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs) where charOfDigit = (credentialAlphabet List.!!) diff --git a/src/Voting/Protocol/Cryptography.hs b/src/Voting/Protocol/Cryptography.hs new file mode 100644 --- /dev/null +++ b/src/Voting/Protocol/Cryptography.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances +module Voting.Protocol.Cryptography where + +import Control.DeepSeq (NFData) +import Control.Monad (Monad(..), join, replicateM) +import Control.Monad.Trans.Except (ExceptT(..), throwE) +import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=)) +import Data.Bits +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Function (($), (.)) +import Data.Functor (Functor, (<$>)) +import Data.Maybe (Maybe(..), fromJust) +import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (IsString(..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import GHC.Natural (minusNaturalMaybe) +import Numeric.Natural (Natural) +import Prelude (Bounded(..), fromIntegral) +import System.Random (RandomGen) +import Text.Show (Show(..)) +import qualified Control.Monad.Trans.State.Strict as S +import qualified Crypto.Hash as Crypto +import qualified Data.Aeson as JSON +import qualified Data.ByteArray as ByteArray +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Builder.Int as TLB +import qualified System.Random as Random + +import Voting.Protocol.Utils +import Voting.Protocol.Arithmetic +import Voting.Protocol.Version + +-- ** Type 'PublicKey' +type PublicKey = G +-- ** Type 'SecretKey' +type SecretKey = E + +-- * Type 'Hash' +newtype Hash crypto c = Hash (E crypto c) + deriving newtype (Eq,Ord,Show,NFData) + +-- | @('hash' bs gs)@ returns as a number in 'E' +-- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs' +-- prefixing the decimal representation of given subgroup elements 'gs', +-- with a comma (",") intercalated between them. +-- +-- NOTE: to avoid any collision when the 'hash' function is used in different contexts, +-- a message 'gs' is actually prefixed by a 'bs' indicating the context. +-- +-- Used by 'proveEncryption' and 'verifyEncryption', +-- where the 'bs' usually contains the 'statement' to be proven, +-- and the 'gs' contains the 'commitments'. +hash :: CryptoParams crypto c => BS.ByteString -> [G crypto c] -> E crypto c +hash bs gs = do + let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs) + let h = Crypto.hashWith Crypto.SHA256 s + fromNatural $ + decodeBigEndian $ ByteArray.convert h + +-- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number. +decodeBigEndian :: BS.ByteString -> Natural +decodeBigEndian = + BS.foldl' + (\acc b -> acc`shiftL`8 + fromIntegral b) + (0::Natural) + +-- ** Type 'Base64SHA256' +newtype Base64SHA256 = Base64SHA256 Text + deriving (Eq,Ord,Show,Generic) + deriving anyclass (ToJSON,FromJSON) + deriving newtype NFData + +-- | @('base64SHA256' bs)@ returns the 'Crypto.SHA256' hash +-- of the given 'BS.ByteString' 'bs', +-- as a 'Text' escaped in @base64@ encoding +-- (). +base64SHA256 :: BS.ByteString -> Base64SHA256 +base64SHA256 bs = + let h = Crypto.hashWith Crypto.SHA256 bs in + Base64SHA256 $ + Text.takeWhile (/= '=') $ -- NOTE: no padding. + Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h + +-- ** Type 'HexSHA256' +newtype HexSHA256 = HexSHA256 Text + deriving (Eq,Ord,Show,Generic) + deriving anyclass (ToJSON,FromJSON) + deriving newtype NFData +-- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash +-- of the given 'BS.ByteString' 'bs', escaped in hexadecimal +-- into a 'Text' of 32 lowercase characters. +-- +-- Used (in retro-dependencies of this library) to hash +-- the 'PublicKey' of a voter or a trustee. +hexSHA256 :: BS.ByteString -> Text +hexSHA256 bs = + let h = Crypto.hashWith Crypto.SHA256 bs in + let n = decodeBigEndian $ ByteArray.convert h in + -- NOTE: always set the 256 bit then remove it + -- to always have leading zeros, + -- and thus always 64 characters wide hashes. + TL.toStrict $ + TL.tail $ TLB.toLazyText $ TLB.hexadecimal $ + setBit n 256 + +-- * Random + +-- | @('randomR' i)@ returns a random integer in @[0..i-1]@. +randomR :: + Monad m => + Random.RandomGen r => + Random.Random i => + Ring i => + i -> S.StateT r m i +randomR i = S.StateT $ return . Random.randomR (zero, i-one) + +-- | @('random')@ returns a random integer +-- in the range determined by its type. +random :: + Monad m => + Random.RandomGen r => + Random.Random i => + Bounded i => + S.StateT r m i +random = S.StateT $ return . Random.random + +-- * Type 'Encryption' +-- | ElGamal-like encryption. +-- Its security relies on the /Discrete Logarithm problem/. +-- +-- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce), +-- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@ +-- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable, +-- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like") +-- to enable the additive homomorphism. +-- +-- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@, +-- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@. +data Encryption crypto v c = Encryption + { encryption_nonce :: !(G crypto c) + -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text, + -- equal to @('groupGen' '^'encNonce)@ + , encryption_vault :: !(G crypto c) + -- ^ Encrypted 'clear' text, + -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ + } deriving (Generic) +deriving instance Eq (G crypto c) => Eq (Encryption crypto v c) +deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c) +deriving instance NFData (G crypto c) => NFData (Encryption crypto v c) +instance + ( Reifies v Version + , CryptoParams crypto c + ) => ToJSON (Encryption crypto v c) where + toJSON Encryption{..} = + JSON.object + [ "alpha" .= encryption_nonce + , "beta" .= encryption_vault + ] + toEncoding Encryption{..} = + JSON.pairs + ( "alpha" .= encryption_nonce + <> "beta" .= encryption_vault + ) +instance + ( Reifies v Version + , CryptoParams crypto c + ) => FromJSON (Encryption crypto v c) where + parseJSON = JSON.withObject "Encryption" $ \o -> do + encryption_nonce <- o .: "alpha" + encryption_vault <- o .: "beta" + return Encryption{..} + +-- | Additive homomorphism. +-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. +instance CryptoParams crypto c => Additive (Encryption crypto v c) where + zero = Encryption one one + x+y = Encryption + (encryption_nonce x * encryption_nonce y) + (encryption_vault x * encryption_vault y) + +-- *** Type 'EncryptionNonce' +type EncryptionNonce = E + +-- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'. +-- +-- WARNING: the secret encryption nonce (@encNonce@) +-- is returned alongside the 'Encryption' +-- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption', +-- but this secret @encNonce@ MUST be forgotten after that, +-- as it may be used to decipher the 'Encryption' +-- without the 'SecretKey' associated with 'pubKey'. +encrypt :: + Reifies v Version => + CryptoParams crypto c => + Monad m => RandomGen r => + PublicKey crypto c -> E crypto c -> + S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c) +encrypt pubKey clear = do + encNonce <- random + -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'. + return $ (encNonce,) + Encryption + { encryption_nonce = groupGen^encNonce + , encryption_vault = pubKey ^encNonce * groupGen^clear + } + +-- * Type 'Proof' +-- | Non-Interactive Zero-Knowledge 'Proof' +-- of knowledge of a discrete logarithm: +-- @(secret == logBase base (base^secret))@. +data Proof crypto v c = Proof + { proof_challenge :: !(Challenge crypto c) + -- ^ 'Challenge' sent by the verifier to the prover + -- to ensure that the prover really has knowledge + -- of the secret and is not replaying. + -- Actually, 'proof_challenge' is not sent to the prover, + -- but derived from the prover's 'Commitment's and statements + -- with a collision resistant 'hash'. + -- Hence the prover cannot chose the 'proof_challenge' to his/her liking. + , proof_response :: !(E crypto c) + -- ^ A discrete logarithm sent by the prover to the verifier, + -- as a response to 'proof_challenge'. + -- + -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where: + -- + -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@, + -- * @commitment '==' 'commit' proof base basePowSec '==' + -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@, + -- * and @basePowSec '==' base'^'sec@, + -- + -- then, with overwhelming probability (due to the 'hash' function), + -- the prover was not able to choose 'proof_challenge' + -- yet was able to compute a 'proof_response' such that + -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@), + -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@, + -- therefore the prover knows 'sec'. + -- + -- The prover choses 'commitment' to be a random power of @base@, + -- to ensure that each 'prove' does not reveal any information + -- about its secret. + } deriving (Eq,Show,NFData,Generic) +instance Reifies v Version => ToJSON (Proof crypto v c) where + toJSON Proof{..} = + JSON.object + [ "challenge" .= proof_challenge + , "response" .= proof_response + ] + toEncoding Proof{..} = + JSON.pairs + ( "challenge" .= proof_challenge + <> "response" .= proof_response + ) +instance + ( CryptoParams crypto c + , Reifies v Version + ) => FromJSON (Proof crypto v c) where + parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do + proof_challenge <- o .: "challenge" + proof_response <- o .: "response" + return Proof{..} + +-- ** Type 'ZKP' +-- | Zero-knowledge proof. +-- +-- A protocol is /zero-knowledge/ if the verifier +-- learns nothing from the protocol except that the prover +-- knows the secret. +-- +-- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical: +-- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993. +newtype ZKP = ZKP BS.ByteString + +-- ** Type 'Challenge' +type Challenge = E + +-- ** Type 'Oracle' +-- An 'Oracle' returns the 'Challenge' of the 'Commitment's +-- by 'hash'ing them (eventually with other 'Commitment's). +-- +-- Used in 'prove' it enables a Fiat-Shamir transformation +-- of an /interactive zero-knowledge/ (IZK) proof +-- into a /non-interactive zero-knowledge/ (NIZK) proof. +-- That is to say that the verifier does not have +-- to send a 'Challenge' to the prover. +-- Indeed, the prover now handles the 'Challenge' +-- which becomes a (collision resistant) 'hash' +-- of the prover's commitments (and statements to be a stronger proof). +type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c + +-- | @('prove' sec commitmentBases oracle)@ +-- returns a 'Proof' that @sec@ is known +-- (by proving the knowledge of its discrete logarithm). +-- +-- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases' +-- raised to the power of the secret nonce of the 'Proof', +-- as those are the 'Commitment's that the verifier will obtain +-- when composing the 'proof_challenge' and 'proof_response' together +-- (with 'commit'). +-- +-- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak): +-- the statement must be included in the 'hash' (along with the commitments). +-- +-- NOTE: a 'random' @nonce@ is used to ensure each 'prove' +-- does not reveal any information regarding the secret @sec@, +-- because two 'Proof's using the same 'Commitment' +-- can be used to deduce @sec@ (using the special-soundness). +prove :: + forall crypto v c list m r. + Reifies v Version => + CryptoParams crypto c => + Monad m => RandomGen r => Functor list => + E crypto c -> + list (G crypto c) -> + Oracle list crypto c -> + S.StateT r m (Proof crypto v c) +prove sec commitmentBases oracle = do + nonce <- random + let commitments = (^ nonce) <$> commitmentBases + let proof_challenge = oracle commitments + return Proof + { proof_challenge + , proof_response = nonce `op` (sec*proof_challenge) + } + where + -- | See comments in 'commit'. + op = + if reflect (Proxy @v) `hasVersionTag` versionTagQuicker + then (-) + else (+) + +-- | Like 'prove' but quicker. It chould replace 'prove' entirely +-- when Helios-C specifications will be fixed. +proveQuicker :: + Reifies v Version => + CryptoParams crypto c => + Monad m => RandomGen r => Functor list => + E crypto c -> + list (G crypto c) -> + Oracle list crypto c -> + S.StateT r m (Proof crypto v c) +proveQuicker sec commitmentBases oracle = do + nonce <- random + let commitments = (^ nonce) <$> commitmentBases + let proof_challenge = oracle commitments + return Proof + { proof_challenge + , proof_response = nonce - sec*proof_challenge + } + +-- | @('fakeProof')@ returns a 'Proof' +-- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random, +-- instead of @('proof_challenge' '==' 'hash' statement commitments)@ +-- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@ +-- as a 'Proof' returned by 'prove'. +-- +-- Used in 'proveEncryption' to fill the returned 'DisjProof' +-- with fake 'Proof's for all 'Disjunction's but the encrypted one. +fakeProof :: + CryptoParams crypto c => + Monad m => RandomGen r => + S.StateT r m (Proof crypto v c) +fakeProof = do + proof_challenge <- random + proof_response <- random + return Proof{..} + +-- ** Type 'Commitment' +-- | A commitment from the prover to the verifier. +-- It's a power of 'groupGen' chosen randomly by the prover +-- when making a 'Proof' with 'prove'. +type Commitment = G + +-- | @('commit' proof base basePowSec)@ returns a 'Commitment' +-- from the given 'Proof' with the knowledge of the verifier. +commit :: + forall crypto v c. + Reifies v Version => + CryptoParams crypto c => + Proof crypto v c -> + G crypto c -> + G crypto c -> + Commitment crypto c +commit Proof{..} base basePowSec = + (base^proof_response) `op` + (basePowSec^proof_challenge) + where + op = + if reflect (Proxy @v) `hasVersionTag` versionTagQuicker + then (*) + else (/) + -- TODO: contrary to some textbook presentations, + -- @('*')@ should be used instead of @('/')@ to avoid the performance cost + -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@, + -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'. +{-# INLINE commit #-} + +-- | Like 'commit' but quicker. It chould replace 'commit' entirely +-- when Helios-C specifications will be fixed. +commitQuicker :: + CryptoParams crypto c => + Proof crypto v c -> + G crypto c -> + G crypto c -> + Commitment crypto c +commitQuicker Proof{..} base basePowSec = + base^proof_response * + basePowSec^proof_challenge + +-- * Type 'Disjunction' +-- | A 'Disjunction' is an 'inverse'd @('groupGen' '^'opinion)@ +-- it's used in 'proveEncryption' to generate a 'Proof' +-- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, +type Disjunction = G + +booleanDisjunctions :: + forall crypto c. + CryptoParams crypto c => + [Disjunction crypto c] +booleanDisjunctions = List.take 2 $ groupGenInverses @crypto + +intervalDisjunctions :: + forall crypto c. + CryptoParams crypto c => + Natural -> Natural -> [Disjunction crypto c] +intervalDisjunctions mini maxi = + List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ + List.genericDrop (nat mini) $ + groupGenInverses @crypto + +-- ** Type 'DisjProof' +-- | A list of 'Proof's to prove that the opinion within an 'Encryption' +-- is indexing a 'Disjunction' within a list of them, +-- without revealing which opinion it is. +newtype DisjProof crypto v c = DisjProof [Proof crypto v c] + deriving (Eq,Show,Generic) + deriving newtype (NFData) +deriving newtype instance Reifies v Version => ToJSON (DisjProof crypto v c) +deriving newtype instance (Reifies v Version, CryptoParams crypto c) => FromJSON (DisjProof crypto v c) + +-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ +-- returns a 'DisjProof' that 'enc' 'encrypt's +-- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'. +-- +-- The prover proves that it knows an 'encNonce', such that: +-- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@ +-- +-- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used. +-- +-- DOC: Pierrick Gaudry. , 2017. +proveEncryption :: + Reifies v Version => + CryptoParams crypto c => + Monad m => RandomGen r => + PublicKey crypto c -> ZKP -> + ([Disjunction crypto c],[Disjunction crypto c]) -> + (EncryptionNonce crypto c, Encryption crypto v c) -> + S.StateT r m (DisjProof crypto v c) +proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do + -- Fake proofs for all 'Disjunction's except the genuine one. + prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof + nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof + let fakeChallengeSum = + sum (proof_challenge <$> prevFakeProofs) + + sum (proof_challenge <$> nextFakeProofs) + let statement = encryptionStatement voterZKP enc + genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments -> + let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in + let prevCommitments = validCommitments prevDisjs prevFakeProofs in + let nextCommitments = validCommitments nextDisjs nextFakeProofs in + let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in + let challenge = hash statement commitments in + let genuineChallenge = challenge - fakeChallengeSum in + genuineChallenge + -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum) + -- thus (sum (proof_challenge <$> proofs) == challenge) + -- as checked in 'verifyEncryption'. + let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs) + return (DisjProof proofs) + +verifyEncryption :: + Reifies v Version => + CryptoParams crypto c => + Monad m => + PublicKey crypto c -> ZKP -> + [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) -> + ExceptT ErrorVerifyEncryption m Bool +verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = + case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of + Nothing -> + throwE $ ErrorVerifyEncryption_InvalidProofLength + (fromIntegral $ List.length proofs) + (fromIntegral $ List.length disjs) + Just commitments -> + return $ challengeSum == + hash (encryptionStatement voterZKP enc) (join commitments) + where + challengeSum = sum (proof_challenge <$> proofs) + +-- ** Hashing +encryptionStatement :: + CryptoParams crypto c => + ZKP -> Encryption crypto v c -> BS.ByteString +encryptionStatement (ZKP voterZKP) Encryption{..} = + "prove|"<>voterZKP<>"|" + <> bytesNat encryption_nonce<>"," + <> bytesNat encryption_vault<>"|" + +-- | @('encryptionCommitments' elecPubKey enc disj proof)@ +-- returns the 'Commitment's with only the knowledge of the verifier. +-- +-- For the prover the 'Proof' comes from @fakeProof@, +-- and for the verifier the 'Proof' comes from the prover. +encryptionCommitments :: + Reifies v Version => + CryptoParams crypto c => + PublicKey crypto c -> Encryption crypto v c -> + Disjunction crypto c -> Proof crypto v c -> [G crypto c] +encryptionCommitments elecPubKey Encryption{..} disj proof = + [ commit proof groupGen encryption_nonce + -- == groupGen ^ nonce if 'Proof' comes from 'prove'. + -- base==groupGen, basePowSec==groupGen^encNonce. + , commit proof elecPubKey (encryption_vault*disj) + -- == elecPubKey ^ nonce if 'Proof' comes from 'prove' + -- and 'encryption_vault' encrypts (- logBase groupGen disj). + -- base==elecPubKey, basePowSec==elecPubKey^encNonce. + ] + +-- ** Type 'ErrorVerifyEncryption' +-- | Error raised by 'verifyEncryption'. +data ErrorVerifyEncryption + = ErrorVerifyEncryption_InvalidProofLength Natural Natural + -- ^ When the number of proofs is different than + -- the number of 'Disjunction's. + deriving (Eq,Show) + +-- * Type 'Signature' +-- | Schnorr-like signature. +-- +-- Used by each voter to sign his/her encrypted 'Ballot' +-- using his/her 'Credential', +-- in order to avoid ballot stuffing. +data Signature crypto v c = Signature + { signature_publicKey :: !(PublicKey crypto c) + -- ^ Verification key. + , signature_proof :: !(Proof crypto v c) + } deriving (Generic) +deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c) +instance + ( Reifies v Version + , CryptoParams crypto c + ) => ToJSON (Signature crypto v c) where + toJSON (Signature pubKey Proof{..}) = + JSON.object + [ "public_key" .= pubKey + , "challenge" .= proof_challenge + , "response" .= proof_response + ] + toEncoding (Signature pubKey Proof{..}) = + JSON.pairs + ( "public_key" .= pubKey + <> "challenge" .= proof_challenge + <> "response" .= proof_response + ) +instance + ( Reifies v Version + , CryptoParams crypto c + ) => FromJSON (Signature crypto v c) where + parseJSON = JSON.withObject "Signature" $ \o -> do + signature_publicKey <- o .: "public_key" + proof_challenge <- o .: "challenge" + proof_response <- o .: "response" + let signature_proof = Proof{..} + return Signature{..} diff --git a/src/Voting/Protocol/Election.hs b/src/Voting/Protocol/Election.hs --- a/src/Voting/Protocol/Election.hs +++ b/src/Voting/Protocol/Election.hs @@ -3,29 +3,28 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} -- for readElection -{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances +{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances module Voting.Protocol.Election where -import Control.Applicative (Applicative(..), Alternative(..)) import Control.DeepSeq (NFData) -import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM) +import Control.Monad (Monad(..), mapM, zipWithM) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT) import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=)) import Data.Bool import Data.Either (either) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldMap, and) +import Data.Foldable (foldMap, and) import Data.Function (($), (.), id, const) -import Data.Functor (Functor, (<$>), (<$)) +import Data.Functor ((<$>)) import Data.Functor.Identity (Identity(..)) -import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe) +import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.Reflection (Reifies(..), reify) import Data.Semigroup (Semigroup(..)) -import Data.String (String, IsString(..)) +import Data.String (String) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd) @@ -35,7 +34,7 @@ import Prelude (fromIntegral) import System.IO (IO, FilePath) import System.Random (RandomGen) -import Text.Show (Show(..), showChar, showString) +import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Aeson as JSON import qualified Data.Aeson.Encoding as JSON @@ -44,424 +43,13 @@ import qualified Data.Aeson.Types as JSON import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import qualified Data.Char as Char import qualified Data.List as List -import qualified Data.Text as Text -import qualified Text.ParserCombinators.ReadP as Read -import qualified Text.Read as Read import Voting.Protocol.Utils -import Voting.Protocol.Arith +import Voting.Protocol.Arithmetic +import Voting.Protocol.Version import Voting.Protocol.Credential - --- * Type 'Encryption' --- | ElGamal-like encryption. --- Its security relies on the /Discrete Logarithm problem/. --- --- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce), --- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@ --- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable, --- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like") --- to enable the additive homomorphism. --- --- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@, --- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@. -data Encryption crypto v c = Encryption - { encryption_nonce :: !(G crypto c) - -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text, - -- equal to @('groupGen' '^'encNonce)@ - , encryption_vault :: !(G crypto c) - -- ^ Encrypted 'clear' text, - -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ - } deriving (Generic) -deriving instance Eq (G crypto c) => Eq (Encryption crypto v c) -deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c) -deriving instance NFData (G crypto c) => NFData (Encryption crypto v c) -instance - ( Reifies v Version - , GroupParams crypto c - ) => ToJSON (Encryption crypto v c) where - toJSON Encryption{..} = - JSON.object - [ "alpha" .= encryption_nonce - , "beta" .= encryption_vault - ] - toEncoding Encryption{..} = - JSON.pairs - ( "alpha" .= encryption_nonce - <> "beta" .= encryption_vault - ) -instance - ( Reifies v Version - , GroupParams crypto c - ) => FromJSON (Encryption crypto v c) where - parseJSON = JSON.withObject "Encryption" $ \o -> do - encryption_nonce <- o .: "alpha" - encryption_vault <- o .: "beta" - return Encryption{..} - --- | Additive homomorphism. --- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. -instance GroupParams crypto c => Additive (Encryption crypto v c) where - zero = Encryption one one - x+y = Encryption - (encryption_nonce x * encryption_nonce y) - (encryption_vault x * encryption_vault y) - --- *** Type 'EncryptionNonce' -type EncryptionNonce = E - --- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'. --- --- WARNING: the secret encryption nonce (@encNonce@) --- is returned alongside the 'Encryption' --- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption', --- but this secret @encNonce@ MUST be forgotten after that, --- as it may be used to decipher the 'Encryption' --- without the 'SecretKey' associated with 'pubKey'. -encrypt :: - Reifies v Version => - GroupParams crypto c => - Monad m => RandomGen r => - PublicKey crypto c -> E crypto c -> - S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c) -encrypt pubKey clear = do - encNonce <- random - -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'. - return $ (encNonce,) - Encryption - { encryption_nonce = groupGen^encNonce - , encryption_vault = pubKey ^encNonce * groupGen^clear - } - --- * Type 'Proof' --- | Non-Interactive Zero-Knowledge 'Proof' --- of knowledge of a discrete logarithm: --- @(secret == logBase base (base^secret))@. -data Proof crypto v c = Proof - { proof_challenge :: !(Challenge crypto c) - -- ^ 'Challenge' sent by the verifier to the prover - -- to ensure that the prover really has knowledge - -- of the secret and is not replaying. - -- Actually, 'proof_challenge' is not sent to the prover, - -- but derived from the prover's 'Commitment's and statements - -- with a collision resistant 'hash'. - -- Hence the prover cannot chose the 'proof_challenge' to his/her liking. - , proof_response :: !(E crypto c) - -- ^ A discrete logarithm sent by the prover to the verifier, - -- as a response to 'proof_challenge'. - -- - -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where: - -- - -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@, - -- * @commitment '==' 'commit' proof base basePowSec '==' - -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@, - -- * and @basePowSec '==' base'^'sec@, - -- - -- then, with overwhelming probability (due to the 'hash' function), - -- the prover was not able to choose 'proof_challenge' - -- yet was able to compute a 'proof_response' such that - -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@), - -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@, - -- therefore the prover knows 'sec'. - -- - -- The prover choses 'commitment' to be a random power of @base@, - -- to ensure that each 'prove' does not reveal any information - -- about its secret. - } deriving (Eq,Show,NFData,Generic) -instance ToJSON (Proof crypto v c) where - toJSON Proof{..} = - JSON.object - [ "challenge" .= proof_challenge - , "response" .= proof_response - ] - toEncoding Proof{..} = - JSON.pairs - ( "challenge" .= proof_challenge - <> "response" .= proof_response - ) -instance GroupParams crypto c => FromJSON (Proof crypto v c) where - parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do - proof_challenge <- o .: "challenge" - proof_response <- o .: "response" - return Proof{..} - --- ** Type 'ZKP' --- | Zero-knowledge proof. --- --- A protocol is /zero-knowledge/ if the verifier --- learns nothing from the protocol except that the prover --- knows the secret. --- --- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical: --- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993. -newtype ZKP = ZKP BS.ByteString - --- ** Type 'Challenge' -type Challenge = E - --- ** Type 'Oracle' --- An 'Oracle' returns the 'Challenge' of the 'Commitment's --- by 'hash'ing them (eventually with other 'Commitment's). --- --- Used in 'prove' it enables a Fiat-Shamir transformation --- of an /interactive zero-knowledge/ (IZK) proof --- into a /non-interactive zero-knowledge/ (NIZK) proof. --- That is to say that the verifier does not have --- to send a 'Challenge' to the prover. --- Indeed, the prover now handles the 'Challenge' --- which becomes a (collision resistant) 'hash' --- of the prover's commitments (and statements to be a stronger proof). -type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c - --- | @('prove' sec commitmentBases oracle)@ --- returns a 'Proof' that @sec@ is known --- (by proving the knowledge of its discrete logarithm). --- --- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases' --- raised to the power of the secret nonce of the 'Proof', --- as those are the 'Commitment's that the verifier will obtain --- when composing the 'proof_challenge' and 'proof_response' together --- (with 'commit'). --- --- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak): --- the statement must be included in the 'hash' (along with the commitments). --- --- NOTE: a 'random' @nonce@ is used to ensure each 'prove' --- does not reveal any information regarding the secret @sec@, --- because two 'Proof's using the same 'Commitment' --- can be used to deduce @sec@ (using the special-soundness). -prove :: - forall crypto v c list m r. - Reifies v Version => - GroupParams crypto c => - Monad m => RandomGen r => Functor list => - E crypto c -> - list (G crypto c) -> - Oracle list crypto c -> - S.StateT r m (Proof crypto v c) -prove sec commitmentBases oracle = do - nonce <- random - let commitments = (^ nonce) <$> commitmentBases - let proof_challenge = oracle commitments - return Proof - { proof_challenge - , proof_response = nonce `op` (sec*proof_challenge) - } - where - -- | See comments in 'commit'. - op = - if reflect (Proxy @v) `hasVersionTag` versionTagQuicker - then (-) - else (+) - --- | Like 'prove' but quicker. It chould replace 'prove' entirely --- when Helios-C specifications will be fixed. -proveQuicker :: - Reifies v Version => - GroupParams crypto c => - Monad m => RandomGen r => Functor list => - E crypto c -> - list (G crypto c) -> - Oracle list crypto c -> - S.StateT r m (Proof crypto v c) -proveQuicker sec commitmentBases oracle = do - nonce <- random - let commitments = (^ nonce) <$> commitmentBases - let proof_challenge = oracle commitments - return Proof - { proof_challenge - , proof_response = nonce - sec*proof_challenge - } - --- | @('fakeProof')@ returns a 'Proof' --- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random, --- instead of @('proof_challenge' '==' 'hash' statement commitments)@ --- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@ --- as a 'Proof' returned by 'prove'. --- --- Used in 'proveEncryption' to fill the returned 'DisjProof' --- with fake 'Proof's for all 'Disjunction's but the encrypted one. -fakeProof :: - GroupParams crypto c => - Monad m => RandomGen r => - S.StateT r m (Proof crypto v c) -fakeProof = do - proof_challenge <- random - proof_response <- random - return Proof{..} - --- ** Type 'Commitment' --- | A commitment from the prover to the verifier. --- It's a power of 'groupGen' chosen randomly by the prover --- when making a 'Proof' with 'prove'. -type Commitment = G - --- | @('commit' proof base basePowSec)@ returns a 'Commitment' --- from the given 'Proof' with the knowledge of the verifier. -commit :: - forall crypto v c. - Reifies v Version => - GroupParams crypto c => - Proof crypto v c -> - G crypto c -> - G crypto c -> - Commitment crypto c -commit Proof{..} base basePowSec = - (base^proof_response) `op` - (basePowSec^proof_challenge) - where - op = - if reflect (Proxy @v) `hasVersionTag` versionTagQuicker - then (*) - else (/) - -- TODO: contrary to some textbook presentations, - -- @('*')@ should be used instead of @('/')@ to avoid the performance cost - -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@, - -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'. -{-# INLINE commit #-} - --- | Like 'commit' but quicker. It chould replace 'commit' entirely --- when Helios-C specifications will be fixed. -commitQuicker :: - GroupParams crypto c => - Proof crypto v c -> - G crypto c -> - G crypto c -> - Commitment crypto c -commitQuicker Proof{..} base basePowSec = - base^proof_response * - basePowSec^proof_challenge - --- * Type 'Disjunction' --- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@ --- it's used in 'proveEncryption' to generate a 'Proof' --- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, -type Disjunction = G - -booleanDisjunctions :: - forall crypto c. - GroupParams crypto c => - [Disjunction crypto c] -booleanDisjunctions = List.take 2 $ groupGenInverses @crypto - -intervalDisjunctions :: - forall crypto c. - GroupParams crypto c => - Natural -> Natural -> [Disjunction crypto c] -intervalDisjunctions mini maxi = - List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ - List.genericDrop (nat mini) $ - groupGenInverses @crypto - --- ** Type 'Opinion' --- | Index of a 'Disjunction' within a list of them. --- It is encrypted as a 'GroupExponent' by 'encrypt'. -type Opinion = E - --- ** Type 'DisjProof' --- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption' --- is indexing a 'Disjunction' within a list of them, --- without revealing which 'Opinion' it is. -newtype DisjProof crypto v c = DisjProof [Proof crypto v c] - deriving (Eq,Show,Generic) - deriving newtype (NFData,ToJSON,FromJSON) - --- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ --- returns a 'DisjProof' that 'enc' 'encrypt's --- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'. --- --- The prover proves that it knows an 'encNonce', such that: --- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@ --- --- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used. --- --- DOC: Pierrick Gaudry. , 2017. -proveEncryption :: - Reifies v Version => - GroupParams crypto c => - Monad m => RandomGen r => - PublicKey crypto c -> ZKP -> - ([Disjunction crypto c],[Disjunction crypto c]) -> - (EncryptionNonce crypto c, Encryption crypto v c) -> - S.StateT r m (DisjProof crypto v c) -proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do - -- Fake proofs for all 'Disjunction's except the genuine one. - prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof - nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof - let fakeChallengeSum = - sum (proof_challenge <$> prevFakeProofs) + - sum (proof_challenge <$> nextFakeProofs) - let statement = encryptionStatement voterZKP enc - genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments -> - let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in - let prevCommitments = validCommitments prevDisjs prevFakeProofs in - let nextCommitments = validCommitments nextDisjs nextFakeProofs in - let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in - let challenge = hash statement commitments in - let genuineChallenge = challenge - fakeChallengeSum in - genuineChallenge - -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum) - -- thus (sum (proof_challenge <$> proofs) == challenge) - -- as checked in 'verifyEncryption'. - let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs) - return (DisjProof proofs) - -verifyEncryption :: - Reifies v Version => - GroupParams crypto c => - Monad m => - PublicKey crypto c -> ZKP -> - [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) -> - ExceptT ErrorVerifyEncryption m Bool -verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = - case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of - Nothing -> - throwE $ ErrorVerifyEncryption_InvalidProofLength - (fromIntegral $ List.length proofs) - (fromIntegral $ List.length disjs) - Just commitments -> - return $ challengeSum == - hash (encryptionStatement voterZKP enc) (join commitments) - where - challengeSum = sum (proof_challenge <$> proofs) - --- ** Hashing -encryptionStatement :: - GroupParams crypto c => - ZKP -> Encryption crypto v c -> BS.ByteString -encryptionStatement (ZKP voterZKP) Encryption{..} = - "prove|"<>voterZKP<>"|" - <> bytesNat encryption_nonce<>"," - <> bytesNat encryption_vault<>"|" - --- | @('encryptionCommitments' elecPubKey enc disj proof)@ --- returns the 'Commitment's with only the knowledge of the verifier. --- --- For the prover the 'Proof' comes from @fakeProof@, --- and for the verifier the 'Proof' comes from the prover. -encryptionCommitments :: - Reifies v Version => - GroupParams crypto c => - PublicKey crypto c -> Encryption crypto v c -> - Disjunction crypto c -> Proof crypto v c -> [G crypto c] -encryptionCommitments elecPubKey Encryption{..} disj proof = - [ commit proof groupGen encryption_nonce - -- == groupGen ^ nonce if 'Proof' comes from 'prove'. - -- base==groupGen, basePowSec==groupGen^encNonce. - , commit proof elecPubKey (encryption_vault*disj) - -- == elecPubKey ^ nonce if 'Proof' comes from 'prove' - -- and 'encryption_vault' encrypts (- logBase groupGen disj). - -- base==elecPubKey, basePowSec==elecPubKey^encNonce. - ] - --- ** Type 'ErrorVerifyEncryption' --- | Error raised by 'verifyEncryption'. -data ErrorVerifyEncryption - = ErrorVerifyEncryption_InvalidProofLength Natural Natural - -- ^ When the number of proofs is different than - -- the number of 'Disjunction's. - deriving (Eq,Show) +import Voting.Protocol.Cryptography -- * Type 'Question' data Question v = Question @@ -509,7 +97,7 @@ deriving instance NFData (G crypto c) => NFData (Answer crypto v c) instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c ) => ToJSON (Answer crypto v c) where toJSON Answer{..} = let (answer_choices, answer_individual_proofs) = @@ -529,7 +117,7 @@ ) instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c ) => FromJSON (Answer crypto v c) where parseJSON = JSON.withObject "Answer" $ \o -> do answer_choices <- o .: "choices" @@ -543,7 +131,7 @@ -- unless an 'ErrorAnswer' is returned. encryptAnswer :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Monad m => RandomGen r => PublicKey crypto c -> ZKP -> Question v -> [Bool] -> @@ -584,7 +172,7 @@ verifyAnswer :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => PublicKey crypto c -> ZKP -> Question v -> Answer crypto v c -> Bool verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..} @@ -611,6 +199,11 @@ -- of 'question_mini' and 'question_maxi'. deriving (Eq,Show,Generic,NFData) +-- ** Type 'Opinion' +-- | Index of a 'Disjunction' within a list of them. +-- It is encrypted as a 'GroupExponent' by 'encrypt'. +type Opinion = E + -- * Type 'Election' data Election crypto v c = Election { election_name :: !Text @@ -627,7 +220,7 @@ deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c) instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c , ToJSON crypto ) => ToJSON (Election crypto v c) where toJSON Election{..} = @@ -657,7 +250,7 @@ hashElection :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => ToJSON crypto => Election crypto v c -> Base64SHA256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode @@ -669,7 +262,7 @@ FilePath -> (forall v c. Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Election crypto v c -> r) -> ExceptT String IO r readElection filePath k = do @@ -713,7 +306,7 @@ deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c) instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c , ToJSON (G crypto c) ) => ToJSON (Ballot crypto v c) where toJSON Ballot{..} = @@ -732,7 +325,7 @@ maybe mempty ("signature" .=) ballot_signature instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c ) => FromJSON (Ballot crypto v c) where parseJSON = JSON.withObject "Ballot" $ \o -> do ballot_answers <- o .: "answers" @@ -747,7 +340,7 @@ -- on each 'question_choices' of each 'election_questions'. encryptBallot :: Reifies v Version => - GroupParams crypto c => Key crypto => + CryptoParams crypto c => Key crypto => Monad m => RandomGen r => Election crypto v c -> Maybe (SecretKey crypto c) -> [[Bool]] -> @@ -780,8 +373,8 @@ -- NOTE: the order is unusual, the commitments are first -- then comes the statement. Best guess is that -- this is easier to code due to their respective types. - (signatureCommitments @crypto voterZKP commitment) - (signatureStatement @crypto ballot_answers) + (ballotCommitments @crypto voterZKP commitment) + (ballotStatement @crypto ballot_answers) return $ Just Signature{..} return Ballot { ballot_answers @@ -792,7 +385,7 @@ verifyBallot :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Election crypto v c -> Ballot crypto v c -> Bool verifyBallot (Election{..}::Election crypto v c) Ballot{..} = @@ -806,72 +399,14 @@ let zkp = ZKP (bytesNat signature_publicKey) in (, zkp) $ proof_challenge signature_proof == hash - (signatureCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey)) - (signatureStatement @crypto ballot_answers) + (ballotCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey)) + (ballotStatement @crypto ballot_answers) in and $ isValidSign : List.zipWith (verifyAnswer election_public_key zkpSign) election_questions ballot_answers --- ** Type 'Signature' --- | Schnorr-like signature. --- --- Used by each voter to sign his/her encrypted 'Ballot' --- using his/her 'Credential', --- in order to avoid ballot stuffing. -data Signature crypto v c = Signature - { signature_publicKey :: !(PublicKey crypto c) - -- ^ Verification key. - , signature_proof :: !(Proof crypto v c) - } deriving (Generic) -deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c) -instance - ( Reifies v Version - , GroupParams crypto c - ) => ToJSON (Signature crypto v c) where - toJSON (Signature pubKey Proof{..}) = - JSON.object - [ "public_key" .= pubKey - , "challenge" .= proof_challenge - , "response" .= proof_response - ] - toEncoding (Signature pubKey Proof{..}) = - JSON.pairs - ( "public_key" .= pubKey - <> "challenge" .= proof_challenge - <> "response" .= proof_response - ) -instance - ( Reifies v Version - , GroupParams crypto c - ) => FromJSON (Signature crypto v c) where - parseJSON = JSON.withObject "Signature" $ \o -> do - signature_publicKey <- o .: "public_key" - proof_challenge <- o .: "challenge" - proof_response <- o .: "response" - let signature_proof = Proof{..} - return Signature{..} --- *** Hashing - --- | @('signatureStatement' answers)@ --- returns the encrypted material to be signed: --- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@. -signatureStatement :: GroupParams crypto c => Foldable f => f (Answer crypto v c) -> [G crypto c] -signatureStatement = - foldMap $ \Answer{..} -> - (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) -> - [encryption_nonce, encryption_vault] - --- | @('signatureCommitments' voterZKP commitment)@ -signatureCommitments :: - GroupParams crypto c => - ToNatural (G crypto c) => - ZKP -> Commitment crypto c -> BS.ByteString -signatureCommitments (ZKP voterZKP) commitment = - "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement - <> bytesNat commitment<>"|" - -- ** Type 'ErrorBallot' -- | Error raised by 'encryptBallot'. data ErrorBallot @@ -884,58 +419,22 @@ -- ^ TODO: to be more precise. deriving (Eq,Show,Generic,NFData) --- * Type 'Version' --- | Version of the Helios-C protocol. -data Version = Version - { version_branch :: [Natural] - , version_tags :: [(Text, Natural)] - } deriving (Eq,Ord,Generic,NFData) -instance IsString Version where - fromString = fromJust . readVersion -instance Show Version where - showsPrec _p Version{..} = - List.foldr (.) id - (List.intersperse (showChar '.') $ - showsPrec 0 <$> version_branch) . - List.foldr (.) id - ((\(t,n) -> showChar '-' . showString (Text.unpack t) . - if n > 0 then showsPrec 0 n else id) - <$> version_tags) -instance ToJSON Version where - toJSON = toJSON . show - toEncoding = toEncoding . show -instance FromJSON Version where - parseJSON (JSON.String s) - | Just v <- readVersion (Text.unpack s) - = return v - parseJSON json = JSON.typeMismatch "Version" json - -hasVersionTag :: Version -> Text -> Bool -hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v) - -experimentalVersion :: Version -experimentalVersion = stableVersion - {version_tags = [(versionTagQuicker,0)]} - -stableVersion :: Version -stableVersion = "1.6" - -versionTagQuicker :: Text -versionTagQuicker = "quicker" +-- ** Hashing -readVersion :: String -> Maybe Version -readVersion = parseReadP $ do - version_branch <- Read.sepBy1 - (Read.read <$> Read.munch1 Char.isDigit) - (Read.char '.') - version_tags <- Read.many $ (,) - <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha) - <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0) - return Version{..} +-- | @('ballotStatement' ballot)@ +-- returns the encrypted material to be signed: +-- all the 'encryption_nonce's and 'encryption_vault's of the given 'ballot_answers'. +ballotStatement :: CryptoParams crypto c => [Answer crypto v c] -> [G crypto c] +ballotStatement = + foldMap $ \Answer{..} -> + (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) -> + [encryption_nonce, encryption_vault] -parseReadP :: Read.ReadP a -> String -> Maybe a -parseReadP p s = - let p' = Read.readP_to_S p in - listToMaybe $ do - (x, "") <- p' s - return x +-- | @('ballotCommitments' voterZKP commitment)@ +ballotCommitments :: + CryptoParams crypto c => + ToNatural (G crypto c) => + ZKP -> Commitment crypto c -> BS.ByteString +ballotCommitments (ZKP voterZKP) commitment = + "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement + <> bytesNat commitment<>"|" diff --git a/src/Voting/Protocol/FFC.hs b/src/Voting/Protocol/FFC.hs --- a/src/Voting/Protocol/FFC.hs +++ b/src/Voting/Protocol/FFC.hs @@ -14,7 +14,7 @@ import Control.Arrow (first) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), unless) -import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=)) +import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.:?), (.=)) import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..)) @@ -41,7 +41,8 @@ import qualified Data.Text.Encoding as Text import qualified System.Random as Random -import Voting.Protocol.Arith +import Voting.Protocol.Arithmetic +import Voting.Protocol.Cryptography import Voting.Protocol.Credential -- * Type 'FFC' @@ -62,12 +63,12 @@ -- ^ The prime number characteristic of a Finite Prime Field. -- -- ElGamal's hardness to decrypt requires a large prime number - -- to form the 'Multiplicative' subgroup. + -- to form the multiplicative subgroup. , ffc_groupGen :: !Natural - -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field. + -- ^ A generator of the multiplicative subgroup of the Finite Prime Field. -- -- NOTE: since 'ffc_fieldCharac' is prime, - -- the 'Multiplicative' subgroup is cyclic, + -- the multiplicative subgroup is cyclic, -- and there are phi('fieldCharac'-1) many choices for the generator of the group, -- where phi is the Euler totient function. , ffc_groupOrder :: !Natural @@ -116,7 +117,7 @@ unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $ JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o) return FFC{..} -instance Reifies c FFC => GroupParams FFC c where +instance Reifies c FFC => CryptoParams FFC c where groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c) groupOrder c = ffc_groupOrder $ reflect c instance ReifyCrypto FFC where @@ -151,7 +152,7 @@ -- | Parameters used in Belenios. -- A 2048-bit 'fieldCharac' of a Finite Prime Field, --- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup +-- with a 256-bit 'groupOrder' for a multiplicative subgroup -- generated by 'groupGen'. beleniosFFC :: FFC beleniosFFC = FFC @@ -166,10 +167,10 @@ -- A field must satisfy the following properties: -- -- * @(f, ('+'), 'zero')@ forms an abelian group, --- called the 'Additive' group of 'f'. +-- called the additive group of 'f'. -- -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group, --- called the 'Multiplicative' group of 'f'. +-- called the multiplicative group of 'f'. -- -- * ('*') is associative: -- @(a'*'b)'*'c == a'*'(b'*'c)@ and @@ -212,13 +213,16 @@ instance Reifies c FFC => Additive (G FFC c) where zero = G 0 G x + G y = G $ (x + y) `mod` fieldCharac @c -instance Reifies c FFC => Negable (G FFC c) where - neg (G x) - | x == 0 = zero - | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x -instance Reifies c FFC => Multiplicative (G FFC c) where +instance Reifies c FFC => Semiring (G FFC c) where one = G 1 G x * G y = G $ (x * y) `mod` fieldCharac @c +instance Reifies c FFC => Ring (G FFC c) where + negate (G x) + | x == 0 = zero + | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x +instance Reifies c FFC => EuclideanRing (G FFC c) where + -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. + inverse = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1)) instance Reifies c FFC => Random.Random (G FFC c) where randomR (G lo, G hi) = first (G . fromIntegral) . @@ -228,6 +232,3 @@ random = first (G . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @c) - 1) -instance Reifies c FFC => Invertible (G FFC c) where - -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. - inv = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1)) diff --git a/src/Voting/Protocol/Tally.hs b/src/Voting/Protocol/Tally.hs --- a/src/Voting/Protocol/Tally.hs +++ b/src/Voting/Protocol/Tally.hs @@ -8,7 +8,7 @@ import Control.DeepSeq (NFData) import Control.Monad (Monad(..), mapM, unless) import Control.Monad.Trans.Except (Except, ExceptT, throwE) -import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.=)) +import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=)) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) @@ -29,7 +29,9 @@ import qualified Data.Map.Strict as Map import Voting.Protocol.Utils -import Voting.Protocol.Arith +import Voting.Protocol.Arithmetic +import Voting.Protocol.Version +import Voting.Protocol.Cryptography import Voting.Protocol.Credential import Voting.Protocol.Election @@ -54,7 +56,7 @@ deriving instance NFData (G crypto c) => NFData (Tally crypto v c) instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c ) => ToJSON (Tally crypto v c) where toJSON Tally{..} = JSON.object @@ -72,7 +74,7 @@ ) instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c ) => FromJSON (Tally crypto v c) where parseJSON = JSON.withObject "Tally" $ \o -> do tally_countMax <- o .: "num_tallied" @@ -89,13 +91,13 @@ -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's. encryptedTally :: - GroupParams crypto c => + CryptoParams crypto c => [Ballot crypto v c] -> (EncryptedTally crypto v c, Natural) encryptedTally = List.foldr insertEncryptedTally emptyEncryptedTally -- | The initial 'EncryptedTally' which tallies no 'Ballot'. emptyEncryptedTally :: - GroupParams crypto c => + CryptoParams crypto c => (EncryptedTally crypto v c, Natural) emptyEncryptedTally = (List.repeat (List.repeat zero), 0) @@ -103,7 +105,7 @@ -- returns the 'EncryptedTally' adding the votes of the given @(ballot)@ -- to those of the given @(encTally)@. insertEncryptedTally :: - GroupParams crypto c => + CryptoParams crypto c => Ballot crypto v c -> (EncryptedTally crypto v c, Natural) -> (EncryptedTally crypto v c, Natural) @@ -122,7 +124,7 @@ Except ErrorTally [[DecryptionFactor crypto c]] proveTally :: - GroupParams crypto c => + CryptoParams crypto c => (EncryptedTally crypto v c, Natural) -> [DecryptionShare crypto v c] -> DecryptionShareCombinator crypto v c -> Except ErrorTally (Tally crypto v c) proveTally @@ -146,7 +148,7 @@ return Tally{..} verifyTally :: - GroupParams crypto c => + CryptoParams crypto c => Tally crypto v c -> DecryptionShareCombinator crypto v c -> Except ErrorTally () @@ -171,7 +173,10 @@ deriving instance Eq (G crypto c) => Eq (DecryptionShare crypto v c) deriving instance Show (G crypto c) => Show (DecryptionShare crypto v c) deriving newtype instance NFData (G crypto c) => NFData (DecryptionShare crypto v c) -instance ToJSON (G crypto c) => ToJSON (DecryptionShare crypto v c) where +instance + ( Reifies v Version + , ToJSON (G crypto c) + ) => ToJSON (DecryptionShare crypto v c) where toJSON (DecryptionShare decByChoiceByQuest) = JSON.object [ "decryption_factors" .= @@ -185,7 +190,10 @@ (JSON.list (JSON.list (toEncoding . fst)) decByChoiceByQuest) <> JSON.pair "decryption_proofs" (JSON.list (JSON.list (toEncoding . snd)) decByChoiceByQuest) -instance GroupParams crypto c => FromJSON (DecryptionShare crypto v c) where +instance + ( Reifies v Version + , CryptoParams crypto c + ) => FromJSON (DecryptionShare crypto v c) where parseJSON = JSON.withObject "DecryptionShare" $ \o -> do decFactors <- o .: "decryption_factors" decProofs <- o .: "decryption_proofs" @@ -203,7 +211,7 @@ -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => Monad m => RandomGen r => EncryptedTally crypto v c -> SecretKey crypto c -> S.StateT r m (DecryptionShare crypto v c) @@ -213,7 +221,7 @@ proveDecryptionFactor :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => Monad m => RandomGen r => SecretKey crypto c -> Encryption crypto v c -> S.StateT r m (DecryptionFactor crypto c, Proof crypto v c) @@ -222,7 +230,7 @@ return (encryption_nonce^trusteeSecKey, proof) where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: GroupParams crypto c => PublicKey crypto c -> BS.ByteString +decryptionShareStatement :: CryptoParams crypto c => PublicKey crypto c -> BS.ByteString decryptionShareStatement pubKey = "decrypt|"<>bytesNat pubKey<>"|" @@ -248,7 +256,7 @@ -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Monad m => EncryptedTally crypto v c -> PublicKey crypto c -> DecryptionShare crypto v c -> ExceptT ErrorTally m () @@ -266,7 +274,7 @@ verifyDecryptionShareByTrustee :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Monad m => EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () diff --git a/src/Voting/Protocol/Trustee/Indispensable.hs b/src/Voting/Protocol/Trustee/Indispensable.hs --- a/src/Voting/Protocol/Trustee/Indispensable.hs +++ b/src/Voting/Protocol/Trustee/Indispensable.hs @@ -7,7 +7,7 @@ import Control.DeepSeq (NFData) import Control.Monad (Monad(..), foldM, unless) import Control.Monad.Trans.Except (ExceptT(..), throwE) -import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.=)) +import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=)) import Data.Eq (Eq(..)) import Data.Function (($)) import Data.Functor ((<$>)) @@ -24,9 +24,10 @@ import qualified Data.List as List import Voting.Protocol.Utils -import Voting.Protocol.Arith +import Voting.Protocol.Arithmetic +import Voting.Protocol.Version +import Voting.Protocol.Cryptography import Voting.Protocol.Credential -import Voting.Protocol.Election import Voting.Protocol.Tally -- * Type 'TrusteePublicKey' @@ -50,7 +51,10 @@ deriving instance Eq (G crypto c) => Eq (TrusteePublicKey crypto v c) deriving instance (Show (G crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) deriving instance NFData (G crypto c) => NFData (TrusteePublicKey crypto v c) -instance ToJSON (G crypto c) => ToJSON (TrusteePublicKey crypto v c) where +instance + ( Reifies v Version + , ToJSON (G crypto c) + ) => ToJSON (TrusteePublicKey crypto v c) where toJSON TrusteePublicKey{..} = JSON.object [ "pok" .= trustee_SecretKeyProof @@ -61,7 +65,10 @@ ( "pok" .= trustee_SecretKeyProof <> "public_key" .= trustee_PublicKey ) -instance GroupParams crypto c => FromJSON (TrusteePublicKey crypto v c) where +instance + ( Reifies v Version + , CryptoParams crypto c + ) => FromJSON (TrusteePublicKey crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do trustee_PublicKey <- o .: "public_key" trustee_SecretKeyProof <- o .: "pok" @@ -74,7 +81,7 @@ -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => Monad m => RandomGen r => SecretKey crypto c -> S.StateT r m (TrusteePublicKey crypto v c) @@ -93,7 +100,7 @@ -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Monad m => TrusteePublicKey crypto v c -> ExceptT ErrorTrusteePublicKey m () @@ -113,7 +120,7 @@ -- ** Hashing indispensableTrusteePublicKeyStatement :: - GroupParams crypto c => + CryptoParams crypto c => PublicKey crypto c -> BS.ByteString indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|" @@ -123,7 +130,7 @@ -- ** Generating an 'Election''s 'PublicKey' from multiple 'TrusteePublicKey's. combineIndispensableTrusteePublicKeys :: - GroupParams crypto c => + CryptoParams crypto c => [TrusteePublicKey crypto v c] -> PublicKey crypto c combineIndispensableTrusteePublicKeys = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one @@ -132,7 +139,7 @@ verifyIndispensableDecryptionShareByTrustee :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Monad m => EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () @@ -146,7 +153,7 @@ -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => [PublicKey crypto c] -> DecryptionShareCombinator crypto v c combineIndispensableDecryptionShares pubKeyByTrustee diff --git a/src/Voting/Protocol/Utils.hs b/src/Voting/Protocol/Utils.hs --- a/src/Voting/Protocol/Utils.hs +++ b/src/Voting/Protocol/Utils.hs @@ -1,18 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Voting.Protocol.Utils where import Control.Applicative (Applicative(..)) +import Control.Arrow (first) import Data.Bool import Data.Either (Either(..), either) import Data.Eq (Eq(..)) import Data.Foldable (sequenceA_) import Data.Function (($), (.)) import Data.Functor ((<$)) -import Data.Maybe (Maybe(..), maybe) +import Data.Maybe (Maybe(..), maybe, listToMaybe) import Data.String (String) import Data.Traversable (Traversable(..)) import Data.Tuple (uncurry) +import Numeric.Natural (Natural) +import Prelude (Integer, fromIntegral) import qualified Data.Aeson.Internal as JSON import qualified Data.List as List +import qualified System.Random as Random +import qualified Text.ParserCombinators.ReadP as Read +import qualified Text.Read as Read -- | Like ('.') but with two arguments. o2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d @@ -62,8 +69,25 @@ maybe err sequenceA_ $ isoZipWith3 f as bs cs +-- * JSON utils + -- | Copied from 'Data.Aeson''s 'eitherFormatError' -- which is not exported. jsonEitherFormatError :: Either (JSON.JSONPath, String) a -> Either String a jsonEitherFormatError = either (Left . uncurry JSON.formatError) Right {-# INLINE jsonEitherFormatError #-} + +instance Random.Random Natural where + randomR (mini,maxi) = + first (fromIntegral::Integer -> Natural) . + Random.randomR (fromIntegral mini, fromIntegral maxi) + random = first (fromIntegral::Integer -> Natural) . Random.random + +-- * Parsing utils + +parseReadP :: Read.ReadP a -> String -> Maybe a +parseReadP p s = + let p' = Read.readP_to_S p in + listToMaybe $ do + (x, "") <- p' s + pure x diff --git a/src/Voting/Protocol/Version.hs b/src/Voting/Protocol/Version.hs new file mode 100644 --- /dev/null +++ b/src/Voting/Protocol/Version.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances +module Voting.Protocol.Version where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.DeepSeq (NFData) +import Control.Monad (Monad(..), join, replicateM) +import Control.Monad.Trans.Except (ExceptT(..), throwE) +import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=)) +import Data.Bits +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Function (($), (.), id) +import Data.Functor (Functor, (<$>), (<$)) +import Data.Maybe (Maybe(..), fromJust, listToMaybe) +import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String, IsString(..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import GHC.Natural (minusNaturalMaybe) +import GHC.TypeLits (Nat, Symbol, natVal, symbolVal, KnownNat, KnownSymbol) +import Numeric.Natural (Natural) +import Prelude (Bounded(..), fromIntegral) +import System.Random (RandomGen) +import Text.Show (Show(..), showChar, showString, shows) +import qualified Control.Monad.Trans.State.Strict as S +import qualified Crypto.Hash as Crypto +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types as JSON +import qualified Data.ByteArray as ByteArray +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Builder.Int as TLB +import qualified System.Random as Random +import qualified Text.ParserCombinators.ReadP as Read +import qualified Text.Read as Read + +import Voting.Protocol.Utils +import Voting.Protocol.Arithmetic + +-- * Type 'Version' +-- | Version of the Helios-C protocol. +data Version = Version + { version_branch :: [Natural] + , version_tags :: [(Text, Natural)] + } deriving (Eq,Ord,Generic,NFData) +instance IsString Version where + fromString = fromJust . readVersion +instance Show Version where + showsPrec _p Version{..} = + List.foldr (.) id + (List.intersperse (showChar '.') $ + shows <$> version_branch) . + List.foldr (.) id + ((\(t,n) -> showChar '-' . showString (Text.unpack t) . + if n > 0 then shows n else id) + <$> version_tags) +instance ToJSON Version where + toJSON = toJSON . show + toEncoding = toEncoding . show +instance FromJSON Version where + parseJSON (JSON.String s) + | Just v <- readVersion (Text.unpack s) + = return v + parseJSON json = JSON.typeMismatch "Version" json + +hasVersionTag :: Version -> Text -> Bool +hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v) + +-- ** Type 'ExperimentalVersion' +type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)] +experimentalVersion :: Version +experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]} + +-- ** Type 'StableVersion' +type StableVersion = V [1,6] '[] +stableVersion :: Version +stableVersion = "1.6" + +-- ** Type 'VersionTagQuicker' +type VersionTagQuicker = "quicker" +versionTagQuicker :: Text +versionTagQuicker = "quicker" + +readVersion :: String -> Maybe Version +readVersion = parseReadP $ do + version_branch <- Read.sepBy1 + (Read.read <$> Read.munch1 Char.isDigit) + (Read.char '.') + version_tags <- Read.many $ (,) + <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha) + <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0) + return Version{..} + +-- ** Type 'V' +-- | Type-level representation of a specific 'Version'. +data V (branch::[Nat]) (tags::[(Symbol,Nat)]) +-- | Like a normal 'reflect' but this one takes +-- its 'Version' from a type-level 'V'ersion +-- instead of a term-level 'Version'. +instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where + reflect _ = Version + { version_branch = versionBranchVal (Proxy @branch) + , version_tags = versionTagsVal (Proxy @tags) + } + +-- *** Class 'VersionBranchVal' +class VersionBranchVal a where + versionBranchVal :: proxy a -> [Natural] +instance KnownNat h => VersionBranchVal '[h] where + versionBranchVal _ = [fromIntegral (natVal (Proxy @h))] +instance + ( KnownNat h + , KnownNat hh + , VersionBranchVal (hh ':t) + ) => VersionBranchVal (h ': hh ': t) where + versionBranchVal _ = + fromIntegral (natVal (Proxy @h)) : + versionBranchVal (Proxy @(hh ':t)) + +-- *** Class 'VersionTagsVal' +class VersionTagsVal a where + versionTagsVal :: proxy a -> [(Text,Natural)] +instance VersionTagsVal '[] where + versionTagsVal _ = [] +instance + ( KnownSymbol s + , KnownNat n + , VersionTagsVal t + ) => VersionTagsVal ('(s,n) ': t) where + versionTagsVal _ = + ( Text.pack (symbolVal (Proxy @s)) + , fromIntegral (natVal (Proxy @n)) + ) : versionTagsVal (Proxy :: Proxy t) diff --git a/tests/HUnit/Election.hs b/tests/HUnit/Election.hs --- a/tests/HUnit/Election.hs +++ b/tests/HUnit/Election.hs @@ -19,11 +19,11 @@ [ testCase "WeakParams" $ reify weakFFC $ \(Proxy::Proxy c) -> List.take 10 (groupGenInverses @_ @c) @?= - [groupGen^neg (fromNatural n) | n <- [0..9]] + [groupGen^negate (fromNatural n) | n <- [0..9]] , testCase "BeleniosParams" $ reify beleniosFFC $ \(Proxy::Proxy c) -> List.take 10 (groupGenInverses @_ @c) @?= - [groupGen^neg (fromNatural n) | n <- [0..9]] + [groupGen^negate (fromNatural n) | n <- [0..9]] ] , testGroup "encryptBallot" $ [ hunitsEncryptBallot v weakFFC diff --git a/tests/HUnit/FFC.hs b/tests/HUnit/FFC.hs --- a/tests/HUnit/FFC.hs +++ b/tests/HUnit/FFC.hs @@ -10,7 +10,7 @@ hunit :: Reifies v Version => Proxy v -> TestTree hunit _v = testGroup "FFC" - [ testGroup "inv" + [ testGroup "inverse" [ hunitInv weakFFC , hunitInv beleniosFFC ] @@ -44,6 +44,6 @@ testGroup (Text.unpack $ cryptoName crypto) [ testCase "groupGen" $ reifyCrypto crypto $ \(_c::Proxy c) -> - inv (groupGen :: G crypto c) @?= + inverse (groupGen :: G crypto c) @?= groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) ] diff --git a/tests/HUnit/Trustee/Indispensable.hs b/tests/HUnit/Trustee/Indispensable.hs --- a/tests/HUnit/Trustee/Indispensable.hs +++ b/tests/HUnit/Trustee/Indispensable.hs @@ -107,7 +107,7 @@ encryptTallyResult :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Monad m => RandomGen r => PublicKey crypto c -> [[Natural]] -> StateT r m (EncryptedTally crypto v c, Natural) encryptTallyResult pubKey countByChoiceByQuest = diff --git a/tests/QuickCheck/Election.hs b/tests/QuickCheck/Election.hs --- a/tests/QuickCheck/Election.hs +++ b/tests/QuickCheck/Election.hs @@ -35,7 +35,7 @@ quickcheckElection :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => JSON.ToJSON crypto => Show crypto => Proxy v -> Proxy c -> TestTree quickcheckElection (_v::Proxy v) (c::Proxy c) = @@ -53,11 +53,11 @@ instance Reifies c FFC => Arbitrary (F c) where arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one) -} -instance GroupParams crypto c => Arbitrary (G crypto c) where +instance CryptoParams crypto c => Arbitrary (G crypto c) where arbitrary = do m <- arbitrary return (groupGen ^ m) -instance GroupParams crypto c => Arbitrary (E crypto c) where +instance CryptoParams crypto c => Arbitrary (E crypto c) where arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one) instance Arbitrary UUID where arbitrary = do @@ -66,7 +66,7 @@ randomUUID instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c , Arbitrary (E crypto c) ) => Arbitrary (Proof crypto v c) where arbitrary = do @@ -90,7 +90,7 @@ ] instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c , Key crypto , JSON.ToJSON crypto ) => Arbitrary (Election crypto v c) where @@ -138,7 +138,7 @@ ] instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c , Key crypto , JSON.ToJSON crypto ) => Arbitrary (Election crypto v c :> [[Bool]]) where diff --git a/tests/QuickCheck/Trustee.hs b/tests/QuickCheck/Trustee.hs --- a/tests/QuickCheck/Trustee.hs +++ b/tests/QuickCheck/Trustee.hs @@ -22,7 +22,7 @@ testIndispensableTrusteePublicKey :: Reifies v Version => - GroupParams crypto c => + CryptoParams crypto c => Key crypto => Proxy v -> Proxy c -> TestTree testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) = @@ -38,7 +38,7 @@ instance ( Reifies v Version - , GroupParams crypto c + , CryptoParams crypto c ) => Arbitrary (TrusteePublicKey crypto v c) where arbitrary = do trustee_PublicKey <- arbitrary