diff --git a/benchmarks/Election.hs b/benchmarks/Election.hs --- a/benchmarks/Election.hs +++ b/benchmarks/Election.hs @@ -1,14 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} module Election where +import Control.DeepSeq (NFData) import qualified Data.List as List import qualified Data.Text as Text import qualified Text.Printf as Printf +import qualified Data.Aeson as JSON import Voting.Protocol import Utils -makeElection :: forall c. Reifies c FFC => Int -> Int -> Election c +makeElection :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + JSON.ToJSON crypto => + JSON.ToJSON (FieldElement crypto c) => + Key crypto => + Int -> Int -> Election crypto v c makeElection nQuests nChoices = elec where election_uuid = UUID "xLcs7ev6Jy6FHH" @@ -16,10 +25,12 @@ { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices , election_description = "benchmarkable election" , election_uuid - , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $ + , election_crypto = reflect (Proxy @c) + , election_public_key = let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in publicKey secKey , election_hash = hashElection elec + , election_version = Just (reflect (Proxy @v)) , election_questions = (<$> [1..nQuests]) $ \quest -> Question { question_text = Text.pack $ "quest"<>show quest @@ -29,13 +40,20 @@ } } -makeVotes :: Election c -> [[Bool]] +makeVotes :: Election crypto v c -> [[Bool]] makeVotes Election{..} = [ True : List.tail [ False | _choice <- question_choices quest ] | quest <- election_questions ] -makeBallot :: Reifies c FFC => Election c -> Ballot c +makeBallot :: + Reifies v Version => + Reifies c crypto => + Group crypto => + Key crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Election crypto v c -> Ballot crypto v c makeBallot elec = case runExcept $ (`evalStateT` mkStdGen seed) $ do ballotSecKey <- randomSecretKey @@ -46,7 +64,7 @@ where seed = 0 -titleElection :: Election c -> String +titleElection :: Election crypto v c -> String titleElection Election{..} = Printf.printf "(questions=%i)×(choices=%i)==%i" nQuests nChoices (nQuests * nChoices) @@ -54,26 +72,48 @@ nQuests = List.length election_questions nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions -benchEncryptBallot :: FFC -> Int -> Int -> Benchmark -benchEncryptBallot ffc nQuests nChoices = - reify ffc $ \(Proxy::Proxy c) -> - let setupEnv = do - let elec :: Election c = makeElection nQuests nChoices - return elec in - env setupEnv $ \ ~(elec) -> - bench (titleElection elec) $ - nf makeBallot elec +benchEncryptBallot :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + JSON.ToJSON crypto => + Group crypto => + Key crypto => + NFData crypto => + NFData (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + JSON.ToJSON (FieldElement crypto c) => + Proxy v -> Proxy c -> Int -> Int -> Benchmark +benchEncryptBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = + let setupEnv = do + let elec :: Election crypto v c = makeElection nQuests nChoices + return elec in + env setupEnv $ \ ~(elec) -> + bench (titleElection elec) $ + nf makeBallot elec -benchVerifyBallot :: FFC -> Int -> Int -> Benchmark -benchVerifyBallot ffc nQuests nChoices = - reify ffc $ \(Proxy::Proxy c) -> - let setupEnv = do - let elec :: Election c = makeElection nQuests nChoices - let ballot = makeBallot elec - return (elec,ballot) in - env setupEnv $ \ ~(elec, ballot) -> - bench (titleElection elec) $ - nf (verifyBallot elec) ballot +benchVerifyBallot :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + JSON.ToJSON crypto => + Group crypto => + Key crypto => + NFData crypto => + NFData (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + JSON.ToJSON (FieldElement crypto c) => + Proxy v -> Proxy c -> Int -> Int -> Benchmark +benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = + let setupEnv = do + let elec :: Election crypto v c = makeElection nQuests nChoices + let ballot = makeBallot elec + return (elec,ballot) in + env setupEnv $ \ ~(elec, ballot) -> + bench (titleElection elec) $ + nf (verifyBallot elec) ballot benchmarks :: [Benchmark] benchmarks = @@ -82,24 +122,26 @@ | nQ <- [1,5,10,15,20,25] , nC <- [5,7] ] in - [ bgroup "weakFFC" - [ bgroup "encryptBallot" - [ benchEncryptBallot weakFFC nQuests nChoices - | (nQuests,nChoices) <- inputs - ] - , bgroup "verifyBallot" - [ benchVerifyBallot weakFFC nQuests nChoices - | (nQuests,nChoices) <- inputs - ] - ] - , bgroup "beleniosFFC" - [ bgroup "encryptBallot" - [ benchEncryptBallot beleniosFFC nQuests nChoices - | (nQuests,nChoices) <- inputs + [ bgroup "stableVersion" $ reify stableVersion $ \v -> + [ bgroup "weakFFC" $ reify weakFFC $ \c -> + [ bgroup "encryptBallot" + [ benchEncryptBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] + , bgroup "verifyBallot" + [ benchVerifyBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] ] - , bgroup "verifyBallot" - [ benchVerifyBallot beleniosFFC nQuests nChoices - | (nQuests,nChoices) <- inputs + , bgroup "beleniosFFC" $ reify beleniosFFC $ \c -> + [ bgroup "encryptBallot" + [ benchEncryptBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] + , bgroup "verifyBallot" + [ benchVerifyBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] ] ] ] 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.7.20190815 +version: 0.0.8.20191027 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: @@ -61,9 +61,10 @@ hs-source-dirs: src exposed-modules: Voting.Protocol - Voting.Protocol.FFC + Voting.Protocol.Arith Voting.Protocol.Credential Voting.Protocol.Election + Voting.Protocol.FFC Voting.Protocol.Tally Voting.Protocol.Trustee Voting.Protocol.Trustee.Indispensable @@ -212,6 +213,7 @@ , hjugement-protocol , containers >= 0.5 , criterion >= 1.4 + , deepseq >= 1.4 , QuickCheck >= 2.11 , random >= 1.1 , text >= 1.2 diff --git a/src/Voting/Protocol.hs b/src/Voting/Protocol.hs --- a/src/Voting/Protocol.hs +++ b/src/Voting/Protocol.hs @@ -1,13 +1,24 @@ module Voting.Protocol - ( module Voting.Protocol.FFC + ( module Voting.Protocol.Arith + , module Voting.Protocol.FFC , module Voting.Protocol.Credential , module Voting.Protocol.Election , module Voting.Protocol.Tally , module Voting.Protocol.Trustee + , Natural + , RandomGen + , Reifies(..), reify + , Proxy(..) ) where +import Voting.Protocol.Arith import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally import Voting.Protocol.Trustee + +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..), reify) +import Numeric.Natural (Natural) +import System.Random (RandomGen) diff --git a/src/Voting/Protocol/Arith.hs b/src/Voting/Protocol/Arith.hs new file mode 100644 --- /dev/null +++ b/src/Voting/Protocol/Arith.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto +{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Finite Field Cryptography (FFC) +-- is a method of implementing discrete logarithm cryptography +-- using finite field mathematics. +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'. +(^) :: + Reifies c crypto => + Multiplicative (FieldElement 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 ^ + +-- | '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. +-- +-- Used by 'intervalDisjunctions'. +groupGenInverses :: + forall crypto c. + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + [G crypto c] +groupGenInverses = go one + where + invGen = inv $ groupGen @crypto @c + go g = g : go (g * invGen) + +groupGenPowers :: + forall crypto c. + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + [G crypto c] +groupGenPowers = go one + where go g = g : go (g * groupGen @crypto @c) + +-- | @('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 + +-- * Type family 'FieldElement' +type family FieldElement crypto :: * -> * + +-- * Class 'Group' where +class Group crypto where + groupGen :: Reifies c crypto => G crypto c + groupOrder :: Reifies c crypto => Proxy c -> Natural + +-- ** Type 'G' +-- | The type of the elements of a subgroup of a field. +newtype G crypto c = G { unG :: FieldElement crypto c } +deriving newtype instance Eq (FieldElement crypto c) => Eq (G crypto c) +deriving newtype instance Ord (FieldElement crypto c) => Ord (G crypto c) +deriving newtype instance Show (FieldElement crypto c) => Show (G crypto c) +deriving newtype instance NFData (FieldElement crypto c) => NFData (G crypto c) +instance ToJSON (FieldElement crypto c) => ToJSON (G crypto c) where + toJSON = JSON.toJSON . unG +instance FromNatural (FieldElement crypto c) => FromNatural (G crypto c) where + fromNatural = G . fromNatural +instance ToNatural (FieldElement crypto c) => ToNatural (G crypto c) where + nat = nat . unG +instance Multiplicative (FieldElement crypto c) => Multiplicative (G crypto c) where + one = G one + G x * G y = G (x * y) +instance + ( Reifies c crypto + , Group crypto + , Multiplicative (FieldElement crypto c) + ) => Invertible (G crypto c) where + -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. + inv = (^ E (fromJust $ groupOrder @crypto (Proxy @c)`minusNaturalMaybe`1)) + +-- ** 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 (Reifies c crypto, Group crypto) => 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 @crypto (Proxy @c) + = return (E x) + parseJSON json = JSON.typeMismatch "Exponent" json +instance (Reifies c crypto, Group crypto) => FromNatural (E crypto c) where + fromNatural i = + E $ abs $ i `mod` groupOrder @crypto (Proxy @c) + where + abs x | x < 0 = x + groupOrder @crypto (Proxy @c) + | otherwise = x +instance ToNatural (E crypto c) where + nat = unE +instance (Reifies c crypto, Group crypto) => Additive (E crypto c) where + zero = E zero + E x + E y = E $ (x + y) `mod` groupOrder @crypto (Proxy @c) +instance (Reifies c crypto, Group crypto) => Negable (E crypto c) where + neg (E x) + | x == 0 = zero + | otherwise = E $ fromJust $ nat (groupOrder @crypto (Proxy @c))`minusNaturalMaybe`x +instance (Reifies c crypto, Group crypto) => Multiplicative (E crypto c) where + one = E one + E x * E y = E $ (x * y) `mod` groupOrder @crypto (Proxy @c) +instance (Reifies c crypto, Group crypto) => 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 @crypto (Proxy @c)) - 1) ) + random = + first (E . fromIntegral) . + Random.randomR (0, toInteger (groupOrder @crypto (Proxy @c)) - 1) +instance (Reifies c crypto, Group crypto) => 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 :: + Reifies c crypto => + Group crypto => + ToNatural (FieldElement 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 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 @@ -14,23 +14,51 @@ import Data.Int (Int) import Data.Maybe (maybe) import Data.Ord (Ord(..)) +import Data.Reflection (Reifies(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import GHC.Generics (Generic) import Prelude (Integral(..), fromIntegral) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S -import qualified Crypto.KDF.PBKDF2 as Crypto import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON 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 System.Random as Random -import Voting.Protocol.FFC +import Voting.Protocol.Arith +-- * Class 'Key' +class Key crypto where + -- | Type of cryptography, eg. "FFC". + cryptoType :: crypto -> Text + -- | Name of the cryptographic paramaters, eg. "Belenios". + cryptoName :: crypto -> Text + -- | Generate a random 'SecretKey'. + randomSecretKey :: + Reifies c crypto => + Monad m => Random.RandomGen r => + S.StateT r m (SecretKey crypto c) + -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey' + -- derived from given 'uuid' and 'cred' + -- using 'Crypto.fastPBKDF2_SHA256'. + credentialSecretKey :: + Reifies c crypto => + UUID -> Credential -> SecretKey crypto c + -- | @('publicKey' secKey)@ returns the 'PublicKey' + -- derived from given 'SecretKey' @secKey@. + publicKey :: + Reifies c crypto => + 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: @@ -128,31 +156,3 @@ digitOfChar c = maybe (Left $ ErrorToken_BadChar c) Right $ List.elemIndex c credentialAlphabet - --- ** Type 'SecretKey' -type SecretKey = E - -randomSecretKey :: Reifies c FFC => Monad m => RandomGen r => S.StateT r m (SecretKey c) -randomSecretKey = random - --- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey' --- derived from given 'uuid' and 'cred' --- using 'Crypto.fastPBKDF2_SHA256'. -credentialSecretKey :: Reifies c FFC => UUID -> Credential -> (SecretKey c) -credentialSecretKey (UUID uuid) (Credential cred) = - fromNatural $ decodeBigEndian $ - Crypto.fastPBKDF2_SHA256 - Crypto.Parameters - { Crypto.iterCounts = 1000 - , Crypto.outputLength = 32 -- bytes, ie. 256 bits - } - (Text.encodeUtf8 cred) - (Text.encodeUtf8 uuid) - --- ** Type 'PublicKey' -type PublicKey = G - --- | @('publicKey' secKey)@ returns the 'PublicKey' --- derived from given 'SecretKey' @secKey@. -publicKey :: Reifies c FFC => SecretKey c -> PublicKey c -publicKey = (groupGen ^) 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 @@ -2,11 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -- for reifyElection +{-# LANGUAGE Rank2Types #-} -- for readElection {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Election where -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative(..), Alternative(..)) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM) import Control.Monad.Trans.Class (MonadTrans(..)) @@ -17,13 +17,15 @@ import Data.Eq (Eq(..)) import Data.Foldable (Foldable, foldMap, and) import Data.Function (($), (.), id, const) -import Data.Functor (Functor, (<$>)) +import Data.Functor (Functor, (<$>), (<$)) import Data.Functor.Identity (Identity(..)) -import Data.Maybe (Maybe(..), maybe, fromJust) +import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe) 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) +import Data.String (String, IsString(..)) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd) @@ -32,16 +34,26 @@ import Numeric.Natural (Natural) import Prelude (fromIntegral) import System.IO (IO, FilePath) -import Text.Show (Show(..)) +import System.Random (RandomGen) +import Text.Show (Show(..), showChar, showString) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Aeson as JSON +import qualified Data.Aeson.Encoding as JSON +import qualified Data.Aeson.Internal as JSON +import qualified Data.Aeson.Parser.Internal as JSON +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.FFC +import Voting.Protocol.Arith import Voting.Protocol.Credential +import Voting.Protocol.FFC (FFC) -- * Type 'Encryption' -- | ElGamal-like encryption. @@ -55,15 +67,22 @@ -- -- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@, -- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@. -data Encryption c = Encryption - { encryption_nonce :: !(G c) +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 c) + , encryption_vault :: !(G crypto c) -- ^ Encrypted 'clear' text, -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ - } deriving (Eq,Show,Generic,NFData) -instance Reifies c FFC => ToJSON (Encryption c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (Encryption crypto v c) +deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Encryption crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (Encryption crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (Encryption crypto v c) where toJSON Encryption{..} = JSON.object [ "alpha" .= encryption_nonce @@ -74,7 +93,11 @@ ( "alpha" .= encryption_nonce <> "beta" .= encryption_vault ) -instance Reifies c FFC => FromJSON (Encryption c) where +instance + ( Reifies v Version + , Reifies c crypto + , FromJSON (G crypto c) + ) => FromJSON (Encryption crypto v c) where parseJSON = JSON.withObject "Encryption" $ \o -> do encryption_nonce <- o .: "alpha" encryption_vault <- o .: "beta" @@ -82,7 +105,10 @@ -- | Additive homomorphism. -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. -instance Reifies c FFC => Additive (Encryption c) where +instance + ( Reifies c crypto + , Multiplicative (FieldElement crypto c) + ) => Additive (Encryption crypto v c) where zero = Encryption one one x+y = Encryption (encryption_nonce x * encryption_nonce y) @@ -100,10 +126,13 @@ -- as it may be used to decipher the 'Encryption' -- without the 'SecretKey' associated with 'pubKey'. encrypt :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> E c -> - S.StateT r m (EncryptionNonce c, Encryption c) + 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'. @@ -117,8 +146,8 @@ -- | Non-Interactive Zero-Knowledge 'Proof' -- of knowledge of a discrete logarithm: -- @(secret == logBase base (base^secret))@. -data Proof c = Proof - { proof_challenge :: Challenge c +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. @@ -126,7 +155,7 @@ -- 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 c + , proof_response :: !(E crypto c) -- ^ A discrete logarithm sent by the prover to the verifier, -- as a response to 'proof_challenge'. -- @@ -147,8 +176,8 @@ -- 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,Generic,NFData) -instance ToJSON (Proof c) where + } deriving (Eq,Show,NFData,Generic) +instance Group crypto => ToJSON (Proof crypto v c) where toJSON Proof{..} = JSON.object [ "challenge" .= proof_challenge @@ -159,7 +188,7 @@ ( "challenge" .= proof_challenge <> "response" .= proof_response ) -instance Reifies c FFC => FromJSON (Proof c) where +instance (Reifies c crypto, Group crypto) => FromJSON (Proof crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do proof_challenge <- o .: "challenge" proof_response <- o .: "response" @@ -191,7 +220,7 @@ -- 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 c = list (Commitment c) -> Challenge c +type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c -- | @('prove' sec commitmentBases oracle)@ -- returns a 'Proof' that @sec@ is known @@ -211,25 +240,43 @@ -- because two 'Proof's using the same 'Commitment' -- can be used to deduce @sec@ (using the special-soundness). prove :: - Reifies c FFC => + forall crypto v c list m r. + Reifies c crypto => + Reifies v Version => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => Functor list => - E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c) + 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 + sec*proof_challenge - -- TODO: switch (+) to (-) when 'commit' will switch (/) to (*). + , 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 c FFC => + Reifies c crypto => + Reifies v Version => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => Functor list => - E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c) + 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 @@ -248,9 +295,10 @@ -- Used in 'proveEncryption' to fill the returned 'DisjProof' -- with fake 'Proof's for all 'Disjunction's but the encrypted one. fakeProof :: - Reifies c FFC => - Monad m => - RandomGen r => S.StateT r m (Proof c) + Reifies c crypto => + Group crypto => + Monad m => RandomGen r => + S.StateT r m (Proof crypto v c) fakeProof = do proof_challenge <- random proof_response <- random @@ -264,19 +312,39 @@ -- | @('commit' proof base basePowSec)@ returns a 'Commitment' -- from the given 'Proof' with the knowledge of the verifier. -commit :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c +commit :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Proof crypto v c -> + G crypto c -> + G crypto c -> + Commitment crypto c commit Proof{..} base basePowSec = - base^proof_response / - basePowSec^proof_challenge + (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 would be compensated by using @('-')@ instead of @('+')@ in 'prove'. + -- 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 :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c +commitQuicker :: + Reifies c crypto => + Multiplicative (FieldElement 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 @@ -287,29 +355,50 @@ -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, type Disjunction = G -booleanDisjunctions :: Reifies c FFC => [Disjunction c] -booleanDisjunctions = List.take 2 groupGenInverses +booleanDisjunctions :: + forall crypto c. + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + [Disjunction crypto c] +booleanDisjunctions = List.take 2 $ groupGenInverses @crypto -intervalDisjunctions :: Reifies c FFC => Natural -> Natural -> [Disjunction c] +intervalDisjunctions :: + forall crypto c. + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Natural -> Natural -> [Disjunction crypto c] intervalDisjunctions mini maxi = List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ List.genericDrop (nat mini) $ - groupGenInverses + groupGenInverses @crypto -- ** Type 'Opinion' -- | Index of a 'Disjunction' within a list of them. --- It is encrypted as an 'E'xponent by 'encrypt'. +-- 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 c = DisjProof [Proof c] +newtype DisjProof crypto v c = DisjProof [Proof crypto v c] deriving (Eq,Show,Generic) - deriving newtype NFData -deriving newtype instance Reifies c FFC => ToJSON (DisjProof c) -deriving newtype instance Reifies c FFC => FromJSON (DisjProof c) + deriving newtype (NFData,ToJSON,FromJSON) +{- +deriving instance Eq (GroupExponent crypto c) => Eq (DisjProof crypto v c) +deriving instance Show (GroupExponent crypto c) => Show (DisjProof crypto v c) +deriving newtype instance NFData (GroupExponent crypto c) => NFData (DisjProof crypto v c) +deriving newtype instance + ( Reifies c crypto + , ToJSON (GroupExponent crypto c) + ) => ToJSON (DisjProof crypto v c) +deriving newtype instance + ( Reifies c crypto + , FromJSON (GroupExponent crypto c) + ) => FromJSON (DisjProof crypto v c) +-} -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ -- returns a 'DisjProof' that 'enc' 'encrypt's @@ -322,12 +411,16 @@ -- -- DOC: Pierrick Gaudry. , 2017. proveEncryption :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + ToNatural (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> ZKP -> - ([Disjunction c],[Disjunction c]) -> - (EncryptionNonce c, Encryption c) -> - S.StateT r m (DisjProof c) + 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 @@ -351,9 +444,14 @@ return (DisjProof proofs) verifyEncryption :: - Reifies c FFC => Monad m => - PublicKey c -> ZKP -> - [Disjunction c] -> (Encryption c, DisjProof c) -> + Reifies v Version => + Reifies c crypto => + Group crypto => + ToNatural (FieldElement crypto c) => + Multiplicative (FieldElement 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 @@ -368,7 +466,10 @@ challengeSum = sum (proof_challenge <$> proofs) -- ** Hashing -encryptionStatement :: Reifies c FFC => ZKP -> Encryption c -> BS.ByteString +encryptionStatement :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + ZKP -> Encryption crypto v c -> BS.ByteString encryptionStatement (ZKP voterZKP) Encryption{..} = "prove|"<>voterZKP<>"|" <> bytesNat encryption_nonce<>"," @@ -380,9 +481,12 @@ -- For the prover the 'Proof' comes from @fakeProof@, -- and for the verifier the 'Proof' comes from the prover. encryptionCommitments :: - Reifies c FFC => - PublicKey c -> Encryption c -> - Disjunction c -> Proof c -> [G c] + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement 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'. @@ -402,14 +506,14 @@ deriving (Eq,Show) -- * Type 'Question' -data Question = Question +data Question v = Question { question_text :: !Text , question_choices :: ![Text] , question_mini :: !Natural , question_maxi :: !Natural -- , question_blank :: Maybe Bool } deriving (Eq,Show,Generic,NFData) -instance ToJSON Question where +instance Reifies v Version => ToJSON (Question v) where toJSON Question{..} = JSON.object [ "question" .= question_text @@ -424,7 +528,7 @@ <> "min" .= question_mini <> "max" .= question_maxi ) -instance FromJSON Question where +instance Reifies v Version => FromJSON (Question v) where parseJSON = JSON.withObject "Question" $ \o -> do question_text <- o .: "question" question_choices <- o .: "answers" @@ -433,16 +537,24 @@ return Question{..} -- * Type 'Answer' -data Answer c = Answer - { answer_opinions :: ![(Encryption c, DisjProof c)] +data Answer crypto v c = Answer + { answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)] -- ^ Encrypted 'Opinion' for each 'question_choices' -- with a 'DisjProof' that they belong to [0,1]. - , answer_sumProof :: !(DisjProof c) + , answer_sumProof :: !(DisjProof crypto v c) -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions' -- is an element of @[mini..maxi]@. -- , answer_blankProof :: - } deriving (Eq,Show,Generic,NFData) -instance Reifies c FFC => ToJSON (Answer c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (Answer crypto v c) +deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Answer crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (Answer crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , ToJSON (FieldElement crypto c) + , Group crypto + ) => ToJSON (Answer crypto v c) where toJSON Answer{..} = let (answer_choices, answer_individual_proofs) = List.unzip answer_opinions in @@ -459,7 +571,12 @@ <> "individual_proofs" .= answer_individual_proofs <> "overall_proof" .= answer_sumProof ) -instance Reifies c FFC => FromJSON (Answer c) where +instance + ( Reifies v Version + , Reifies c crypto + , FromJSON (G crypto c) + , Group crypto + ) => FromJSON (Answer crypto v c) where parseJSON = JSON.withObject "Answer" $ \o -> do answer_choices <- o .: "choices" answer_individual_proofs <- o .: "individual_proofs" @@ -471,11 +588,15 @@ -- returns an 'Answer' validable by 'verifyAnswer', -- unless an 'ErrorAnswer' is returned. encryptAnswer :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> ZKP -> - Question -> [Bool] -> - S.StateT r (ExceptT ErrorAnswer m) (Answer c) + PublicKey crypto c -> ZKP -> + Question v -> [Bool] -> + S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c) encryptAnswer elecPubKey zkp Question{..} opinionByChoice | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) = lift $ throwE $ @@ -511,9 +632,13 @@ opinions = (\o -> if o then one else zero) <$> opinionByChoice verifyAnswer :: - Reifies c FFC => - PublicKey c -> ZKP -> - Question -> Answer c -> Bool + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + PublicKey crypto c -> ZKP -> + Question v -> Answer crypto v c -> Bool verifyAnswer elecPubKey zkp Question{..} Answer{..} | List.length question_choices /= List.length answer_opinions = False | otherwise = either (const False) id $ runExcept $ do @@ -538,91 +663,160 @@ deriving (Eq,Show,Generic,NFData) -- * Type 'Election' -data Election c = Election +data Election crypto v c = Election { election_name :: !Text , election_description :: !Text - , election_crypto :: !(ElectionCrypto c) - , election_questions :: ![Question] + , election_questions :: ![Question v] , election_uuid :: !UUID , election_hash :: Base64SHA256 - } deriving (Eq,Show,Generic,NFData) - -instance ToJSON (Election c) where + , election_crypto :: !crypto + , election_version :: !(Maybe Version) + , election_public_key :: !(PublicKey crypto c) + } deriving (Generic) +deriving instance (Eq crypto, Eq (FieldElement crypto c)) => Eq (Election crypto v c) +deriving instance (Show crypto, Show (FieldElement crypto c)) => Show (Election crypto v c) +deriving instance (NFData crypto, NFData (FieldElement crypto c)) => NFData (Election crypto v c) +instance + ( ToJSON crypto + , ToJSON (FieldElement crypto c) + , Reifies v Version + , Reifies c crypto + ) => ToJSON (Election crypto v c) where toJSON Election{..} = - JSON.object - [ "name" .= election_name + JSON.object $ + [ "name" .= election_name , "description" .= election_description - , "public_key" .= election_crypto - , "questions" .= election_questions - , "uuid" .= election_uuid - ] + , ("public_key", JSON.object + [ "group" .= election_crypto + , "y" .= election_public_key + ]) + , "questions" .= election_questions + , "uuid" .= election_uuid + ] <> + maybe [] (\version -> [ "version" .= version ]) election_version toEncoding Election{..} = - JSON.pairs - ( "name" .= election_name + JSON.pairs $ + ( "name" .= election_name <> "description" .= election_description - <> "public_key" .= election_crypto - <> "questions" .= election_questions - <> "uuid" .= election_uuid + <> JSON.pair "public_key" (JSON.pairs $ + "group" .= election_crypto + <> "y" .= election_public_key ) -instance FromJSON (Election ()) where - parseJSON = JSON.withObject "Election" $ \o -> Election - <$> o .: "name" - <*> o .: "description" - <*> o .: "public_key" - <*> o .: "questions" - <*> o .: "uuid" - <*> pure (Base64SHA256 "") - -- NOTE: set in 'readElection'. + <> "questions" .= election_questions + <> "uuid" .= election_uuid + ) <> + maybe mempty ("version" .=) election_version -readElection :: FilePath -> ExceptT String IO (Election ()) -readElection filePath = do +readElection :: + ReifyCrypto crypto => + FromJSON crypto => + FilePath -> + (forall v c. + Reifies v Version => + Reifies c crypto => + FieldElementConstraints crypto c => + Election crypto v c -> r) -> + ExceptT String IO r +readElection filePath k = do fileData <- lift $ BS.readFile filePath ExceptT $ return $ - (\e -> e{election_hash=base64SHA256 fileData}) - <$> JSON.eitherDecodeStrict' fileData + jsonEitherFormatError $ + JSON.eitherDecodeStrictWith JSON.jsonEOF + (JSON.iparse (parseElection fileData)) + fileData + where + parseElection fileData = JSON.withObject "Election" $ \o -> do + election_version <- o .:? "version" + reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do + (election_crypto, elecPubKey) <- + JSON.explicitParseField + (JSON.withObject "public_key" $ \obj -> do + crypto <- obj .: "group" + pubKey :: JSON.Value <- obj .: "y" + return (crypto, pubKey) + ) o "public_key" + reifyCrypto election_crypto $ \(_c::Proxy c) -> do + election_name <- o .: "name" + election_description <- o .: "description" + election_questions <- o .: "questions" :: JSON.Parser [Question v] + election_uuid <- o .: "uuid" + election_public_key :: PublicKey crypto c <- parseJSON elecPubKey + return $ k $ Election + { election_questions = election_questions + , election_public_key = election_public_key + , election_hash = base64SHA256 fileData + , .. + } -hashElection :: Election c -> Base64SHA256 +hashElection :: + ToJSON crypto => + Reifies c crypto => + Reifies v Version => + ToJSON (FieldElement crypto c) => + Election crypto v c -> Base64SHA256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode --- ** Type 'ElectionCrypto' -data ElectionCrypto c = - ElectionCrypto_FFC - { electionCrypto_FFC_params :: !FFC - , electionCrypto_FFC_PublicKey :: !(PublicKey c) - } deriving (Eq,Show,Generic,NFData) - -reifyElection :: Election () -> (forall c. Reifies c FFC => Election c -> k) -> k -reifyElection Election{..} k = - case election_crypto of - ElectionCrypto_FFC ffc (G (F pubKey)) -> - reify ffc $ \(_::Proxy c) -> k @c - Election{election_crypto = ElectionCrypto_FFC ffc (G (F pubKey)), ..} +-- ** Class 'ReifyCrypto' +-- | @('reifyCrypto' crypto k)@ is like @('reify' crypto k)@ +-- but gives to @(k)@ more constraints than just @('Reifies' c crypto)@, +-- which is used when defining classes on @(crypto)@ +-- where @(c)@ (the type variable guarantying the same +-- @crypto@graphic parameters are used throughout) +-- is not yet in scope and thus where one cannot +-- add those constraints requiring to have @(c)@ in scope. +-- See for instance the 'QuickcheckElection' class, in the tests. +-- +-- For convenience, the 'ReifyCrypto' class also implies the pervasive +-- constraint 'Group'. +class + ( Group crypto + , Key crypto + , Show crypto + , NFData crypto + , JSON.ToJSON crypto + , JSON.FromJSON crypto + ) => ReifyCrypto crypto where + reifyCrypto :: + crypto -> (forall c. + Reifies c crypto => + FieldElementConstraints crypto c => + Proxy c -> r) -> r +instance ReifyCrypto FFC where + reifyCrypto = reify -instance ToJSON (ElectionCrypto c) where - toJSON (ElectionCrypto_FFC ffc pubKey) = - JSON.object - [ "group" .= ffc - , "y" .= pubKey - ] - toEncoding (ElectionCrypto_FFC ffc pubKey) = - JSON.pairs - ( "group" .= ffc - <> "y" .= pubKey - ) -instance FromJSON (ElectionCrypto ()) where - parseJSON = JSON.withObject "ElectionCrypto" $ \o -> do - ffc <- o .: "group" - pubKey <- reify ffc $ \(_::Proxy s) -> nat <$> ((.:) @(PublicKey s) o "y") - return $ ElectionCrypto_FFC ffc (G (F pubKey)) +-- ** Class 'FieldElementConstraints' +-- | List the 'Constraint's on the element of the field +-- when the @(crypto)@ has not been instantiated to a specific type yet. +-- It concerns only 'Constraint's whose method act on @(a)@, +-- not @(x c)@ (eg. 'Group'). +type FieldElementConstraints crypto c = + ( Multiplicative (FieldElement crypto c) + , FromNatural (FieldElement crypto c) + , ToNatural (FieldElement crypto c) + , Eq (FieldElement crypto c) + , Ord (FieldElement crypto c) + , Show (FieldElement crypto c) + , NFData (FieldElement crypto c) + , FromJSON (FieldElement crypto c) + , ToJSON (FieldElement crypto c) + , FromJSON (G crypto c) + , ToJSON (G crypto c) + ) -- * Type 'Ballot' -data Ballot c = Ballot - { ballot_answers :: ![Answer c] - , ballot_signature :: !(Maybe (Signature c)) +data Ballot crypto v c = Ballot + { ballot_answers :: ![Answer crypto v c] + , ballot_signature :: !(Maybe (Signature crypto v c)) , ballot_election_uuid :: !UUID , ballot_election_hash :: !Base64SHA256 - } deriving (Generic,NFData) -instance Reifies c FFC => ToJSON (Ballot c) where + } deriving (Generic) +deriving instance (NFData (FieldElement crypto c), NFData crypto) => NFData (Ballot crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (Ballot crypto v c) where toJSON Ballot{..} = JSON.object $ [ "answers" .= ballot_answers @@ -636,8 +830,13 @@ <> "election_uuid" .= ballot_election_uuid <> "election_hash" .= ballot_election_hash ) <> - maybe mempty (\sig -> "signature" .= sig) ballot_signature -instance Reifies c FFC => FromJSON (Ballot c) where + maybe mempty ("signature" .=) ballot_signature +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , FromJSON (G crypto c) + ) => FromJSON (Ballot crypto v c) where parseJSON = JSON.withObject "Ballot" $ \o -> do ballot_answers <- o .: "answers" ballot_signature <- o .:? "signature" @@ -645,16 +844,22 @@ ballot_election_hash <- o .: "election_hash" return Ballot{..} --- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@ +-- | @('encryptBallot' c ('Just' ballotSecKey) opinionsByQuest)@ -- returns a 'Ballot' signed by 'secKey' (the voter's secret key) -- where 'opinionsByQuest' is a list of 'Opinion's -- on each 'question_choices' of each 'election_questions'. encryptBallot :: - Reifies c FFC => + forall crypto m v c r. + Reifies c crypto => + Reifies v Version => + Group crypto => + Key crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => Monad m => RandomGen r => - Election c -> - Maybe (SecretKey c) -> [[Bool]] -> - S.StateT r (ExceptT ErrorBallot m) (Ballot c) + Election crypto v c -> + Maybe (SecretKey crypto c) -> [[Bool]] -> + S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c) encryptBallot Election{..} ballotSecKeyMay opinionsByQuest | List.length election_questions /= List.length opinionsByQuest = lift $ throwE $ @@ -671,7 +876,7 @@ where ballotPubKey = publicKey ballotSecKey ballot_answers <- S.mapStateT (withExceptT ErrorBallot_Answer) $ - zipWithM (encryptAnswer (electionCrypto_FFC_PublicKey election_crypto) voterZKP) + zipWithM (encryptAnswer election_public_key voterZKP) election_questions opinionsByQuest ballot_signature <- case voterKeys of Nothing -> return Nothing @@ -679,12 +884,12 @@ signature_proof <- proveQuicker ballotSecKey (Identity groupGen) $ \(Identity commitment) -> - hash + hash @_ @crypto -- 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 voterZKP commitment) - (signatureStatement ballot_answers) + (signatureCommitments @_ @crypto voterZKP commitment) + (signatureStatement @_ @crypto ballot_answers) return $ Just Signature{..} return Ballot { ballot_answers @@ -693,9 +898,17 @@ , ballot_signature } -verifyBallot :: Reifies c FFC => Election c -> Ballot c -> Bool +verifyBallot :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + ToNatural (PublicKey crypto c) => + Election crypto v c -> + Ballot crypto v c -> Bool verifyBallot Election{..} Ballot{..} = - let elecPubKey = electionCrypto_FFC_PublicKey election_crypto in ballot_election_uuid == election_uuid && ballot_election_hash == election_hash && List.length election_questions == List.length ballot_answers && @@ -706,11 +919,11 @@ let zkp = ZKP (bytesNat signature_publicKey) in (, zkp) $ proof_challenge signature_proof == hash - (signatureCommitments zkp (commitQuicker signature_proof groupGen signature_publicKey)) - (signatureStatement ballot_answers) + (signatureCommitments @_ @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey)) + (signatureStatement @_ @crypto ballot_answers) in and $ isValidSign : - List.zipWith (verifyAnswer elecPubKey zkpSign) + List.zipWith (verifyAnswer election_public_key zkpSign) election_questions ballot_answers -- ** Type 'Signature' @@ -719,12 +932,20 @@ -- Used by each voter to sign his/her encrypted 'Ballot' -- using his/her 'Credential', -- in order to avoid ballot stuffing. -data Signature c = Signature - { signature_publicKey :: !(PublicKey c) +data Signature crypto v c = Signature + { signature_publicKey :: !(PublicKey crypto c) -- ^ Verification key. - , signature_proof :: !(Proof c) - } deriving (Generic,NFData) -instance Reifies c FFC => ToJSON (Signature c) where + , signature_proof :: !(Proof crypto v c) + } deriving (Generic) +deriving instance + ( NFData crypto + , NFData (FieldElement crypto c) + ) => NFData (Signature crypto v c) +instance + ( Reifies c crypto + , Reifies v Version + , ToJSON (FieldElement crypto c) + ) => ToJSON (Signature crypto v c) where toJSON (Signature pubKey Proof{..}) = JSON.object [ "public_key" .= pubKey @@ -737,7 +958,12 @@ <> "challenge" .= proof_challenge <> "response" .= proof_response ) -instance Reifies c FFC => FromJSON (Signature c) where +instance + ( Reifies c crypto + , Reifies v Version + , Group crypto + , FromJSON (PublicKey crypto c) + ) => FromJSON (Signature crypto v c) where parseJSON = JSON.withObject "Signature" $ \o -> do signature_publicKey <- o .: "public_key" proof_challenge <- o .: "challenge" @@ -750,14 +976,17 @@ -- | @('signatureStatement' answers)@ -- returns the encrypted material to be signed: -- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@. -signatureStatement :: Reifies c FFC => Foldable f => f (Answer c) -> [G c] +signatureStatement :: Reifies c crypto => 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 :: ZKP -> Commitment c -> BS.ByteString +signatureCommitments :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + ZKP -> Commitment crypto c -> BS.ByteString signatureCommitments (ZKP voterZKP) commitment = "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement <> bytesNat commitment<>"|" @@ -773,3 +1002,59 @@ | ErrorBallot_Wrong -- ^ 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" + +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{..} + +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 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 @@ -1,63 +1,49 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Finite Field Cryptography (FFC) -- is a method of implementing discrete logarithm cryptography -- using finite field mathematics. -module Voting.Protocol.FFC - ( module Voting.Protocol.FFC - , Natural - , Random.RandomGen - , Reifies(..), reify - , Proxy(..) - ) where +module Voting.Protocol.FFC where import Control.Arrow (first) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), unless) import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=)) -import Data.Bits import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldl') -import Data.Function (($), (.), id) +import Data.Function (($), (.)) import Data.Functor ((<$>)) -import Data.Int (Int) import Data.Maybe (Maybe(..), fromMaybe, fromJust) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) -import Data.Reflection (Reifies(..), reify) +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 Prelude (Integral(..), fromIntegral) import Text.Read (readMaybe, readEither) import Text.Show (Show(..)) -import qualified Control.Monad.Trans.State.Strict as S -import qualified Crypto.Hash as Crypto +import qualified Crypto.KDF.PBKDF2 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 +import Voting.Protocol.Arith +import Voting.Protocol.Credential + -- * Type 'FFC' -- | Mutiplicative Sub-Group of a Finite Prime Field. -- @@ -130,15 +116,14 @@ 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 Group FFC where + groupGen :: forall c. Reifies c FFC => G FFC c + groupGen = G $ F $ ffc_groupGen $ reflect (Proxy::Proxy c) + groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural + groupOrder c = ffc_groupOrder $ reflect c fieldCharac :: forall c. Reifies c FFC => Natural -fieldCharac = ffc_fieldCharac (reflect (Proxy::Proxy c)) - -groupGen :: forall c. Reifies c FFC => G c -groupGen = G $ F $ ffc_groupGen (reflect (Proxy::Proxy c)) - -groupOrder :: forall c. Reifies c FFC => Natural -groupOrder = ffc_groupOrder (reflect (Proxy::Proxy c)) +fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c) -- ** Examples -- | Weak parameters for debugging purposes only. @@ -189,8 +174,7 @@ newtype F c = F { unF :: Natural } deriving (Eq,Ord,Show) deriving newtype NFData -instance ToJSON (F c) where - toJSON (F x) = JSON.toJSON (show x) +type instance FieldElement FFC = F instance Reifies c FFC => FromJSON (F c) where parseJSON (JSON.String s) | Just (c0,_) <- Text.uncons s @@ -199,7 +183,20 @@ , Just x <- readMaybe (Text.unpack s) , x < fieldCharac @c = return (F x) - parseJSON json = JSON.typeMismatch "FieldElement" json + parseJSON json = JSON.typeMismatch "FieldElement FFC" json +instance Reifies c FFC => FromJSON (G FFC 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 < fieldCharac @c + , r <- G (F x) + , r ^ E (groupOrder @FFC (Proxy @c)) == one + = return r + parseJSON json = JSON.typeMismatch "GroupElement" json +instance ToJSON (F c) where + toJSON (F x) = JSON.toJSON (show x) instance Reifies c FFC => FromNatural (F c) where fromNatural i = F $ abs $ i `mod` fieldCharac @c where @@ -227,267 +224,19 @@ first (F . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @c) - 1) --- ** 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 - --- * Type 'G' --- | The type of the elements of a 'Multiplicative' subgroup of a Finite Prime Field. -newtype G c = G { unG :: F c } - deriving (Eq,Ord,Show) - deriving newtype NFData -instance ToJSON (G c) where - toJSON (G x) = JSON.toJSON x -instance Reifies c FFC => FromJSON (G 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 < fieldCharac @c - , r <- G (F x) - , r ^ E (groupOrder @c) == one - = return r - parseJSON json = JSON.typeMismatch "GroupElement" json -instance Reifies c FFC => FromNatural (G c) where - fromNatural = G . fromNatural -instance ToNatural (G c) where - nat = unF . unG -instance Reifies c FFC => Multiplicative (G c) where - one = G $ F one - G x * G y = G (x * y) -instance Reifies c FFC => Invertible (G c) where - -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. - inv = (^ E (fromJust $ groupOrder @c`minusNaturalMaybe`1)) - --- | '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. --- --- Used by 'intervalDisjunctions'. -groupGenInverses :: forall c. Reifies c FFC => [G c] -groupGenInverses = go one - where - invGen = inv $ groupGen @c - go g = g : go (g * invGen) - -groupGenPowers :: forall c. Reifies c FFC => [G c] -groupGenPowers = go one - where go g = g : go (g * groupGen @c) - --- ** Type 'Hash' -newtype Hash c = Hash (E c) - deriving (Eq,Ord,Show) - deriving newtype 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 :: Reifies c FFC => BS.ByteString -> [G c] -> E 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 - --- * Type 'E' --- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field. --- The value is always in @[0..'groupOrder'-1]@. -newtype E c = E { unE :: Natural } - deriving (Eq,Ord,Show) - deriving newtype NFData -instance ToJSON (E c) where - toJSON (E x) = JSON.toJSON (show x) -instance Reifies c FFC => FromJSON (E 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 @c - = return (E x) - parseJSON json = JSON.typeMismatch "Exponent" json - -instance Reifies c FFC => FromNatural (E c) where - fromNatural i = - E $ abs $ i `mod` groupOrder @c - where - abs x | x < 0 = x + groupOrder @c - | otherwise = x -instance ToNatural (E c) where - nat = unE - -instance Reifies c FFC => Additive (E c) where - zero = E zero - E x + E y = E $ (x + y) `mod` groupOrder @c -instance Reifies c FFC => Negable (E c) where - neg (E x) - | x == 0 = zero - | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x -instance Reifies c FFC => Multiplicative (E c) where - one = E one - E x * E y = E $ (x * y) `mod` groupOrder @c -instance Reifies c FFC => Random.Random (E c) where - randomR (E lo, E hi) = - first (E . fromIntegral) . - Random.randomR - ( 0`max`toInteger lo - , toInteger hi`min`(toInteger (groupOrder @c) - 1) ) - random = - first (E . fromIntegral) . - Random.randomR (0, toInteger (groupOrder @c) - 1) -instance Reifies c FFC => Enum (E 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 - -infixr 8 ^ --- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'. -(^) :: Reifies c FFC => G c -> E c -> G c -(^) b (E e) - | e == 0 = one - | otherwise = t * (b*b) ^ E (e`shiftR`1) - where - t | testBit e 0 = b - | otherwise = one - --- | @('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 - -- * Conversions --- ** 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 +instance Key FFC where + cryptoType _ = "FFC" + cryptoName = ffc_name + randomSecretKey = random + credentialSecretKey (UUID uuid) (Credential cred) = + fromNatural $ decodeBigEndian $ + Crypto.fastPBKDF2_SHA256 + Crypto.Parameters + { Crypto.iterCounts = 1000 + , Crypto.outputLength = 32 -- bytes, ie. 256 bits + } + (Text.encodeUtf8 cred) + (Text.encodeUtf8 uuid) + publicKey = (groupGen @FFC ^) 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 @@ -14,9 +14,12 @@ import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..)) +import Data.Ord (Ord(..)) +import Data.Reflection (Reifies(..)) import Data.Tuple (fst, snd) import GHC.Generics (Generic) import Numeric.Natural (Natural) +import System.Random (RandomGen) import Text.Show (Show(..)) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON @@ -27,12 +30,12 @@ import qualified Data.Map.Strict as Map import Voting.Protocol.Utils -import Voting.Protocol.FFC +import Voting.Protocol.Arith import Voting.Protocol.Credential import Voting.Protocol.Election -- * Type 'Tally' -data Tally c = Tally +data Tally crypto v c = Tally { tally_countMax :: !Natural -- ^ The maximal number of supportive 'Opinion's that a choice can get, -- which is here the same as the number of 'Ballot's. @@ -40,14 +43,22 @@ -- Used in 'proveTally' to decrypt the actual -- count of votes obtained by a choice, -- by precomputing all powers of 'groupGen's up to it. - , tally_encByChoiceByQuest :: !(EncryptedTally c) + , tally_encByChoiceByQuest :: !(EncryptedTally crypto v c) -- ^ 'Encryption' by 'Question' by 'Ballot'. - , tally_decShareByTrustee :: ![DecryptionShare c] + , tally_decShareByTrustee :: ![DecryptionShare crypto v c] -- ^ 'DecryptionShare' by trustee. , tally_countByChoiceByQuest :: ![[Natural]] -- ^ The decrypted count of supportive 'Opinion's, by choice by 'Question'. - } deriving (Eq,Show,Generic,NFData) -instance Reifies c FFC => ToJSON (Tally c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (Tally crypto v c) +deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Tally crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (Tally crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (Tally crypto v c) where toJSON Tally{..} = JSON.object [ "num_tallied" .= tally_countMax @@ -62,7 +73,12 @@ <> "partial_decryptions" .= tally_decShareByTrustee <> "result" .= tally_countByChoiceByQuest ) -instance Reifies c FFC => FromJSON (Tally c) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , FromJSON (G crypto c) + ) => FromJSON (Tally crypto v c) where parseJSON = JSON.withObject "Tally" $ \o -> do tally_countMax <- o .: "num_tallied" tally_encByChoiceByQuest <- o .: "encrypted_tally" @@ -72,22 +88,31 @@ -- ** Type 'EncryptedTally' -- | 'Encryption' by choice by 'Question'. -type EncryptedTally c = [[Encryption c]] +type EncryptedTally crypto v c = [[Encryption crypto v c]] -- | @('encryptedTally' ballots)@ -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's. -encryptedTally :: Reifies c FFC => [Ballot c] -> (EncryptedTally c, Natural) +encryptedTally :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + [Ballot crypto v c] -> (EncryptedTally crypto v c, Natural) encryptedTally = List.foldr insertEncryptedTally emptyEncryptedTally -- | The initial 'EncryptedTally' which tallies no 'Ballot'. -emptyEncryptedTally :: Reifies c FFC => (EncryptedTally c, Natural) +emptyEncryptedTally :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + (EncryptedTally crypto v c, Natural) emptyEncryptedTally = (List.repeat (List.repeat zero), 0) -- | @('insertEncryptedTally' ballot encTally)@ -- returns the 'EncryptedTally' adding the votes of the given @(ballot)@ -- to those of the given @(encTally)@. -insertEncryptedTally :: Reifies c FFC => Ballot c -> (EncryptedTally c, Natural) -> (EncryptedTally c, Natural) +insertEncryptedTally :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + Ballot crypto v c -> (EncryptedTally crypto v c, Natural) -> (EncryptedTally crypto v c, Natural) insertEncryptedTally Ballot{..} (encTally, numBallots) = ( List.zipWith (\Answer{..} -> List.zipWith (+) (fst <$> answer_opinions)) @@ -97,14 +122,19 @@ ) -- ** Type 'DecryptionShareCombinator' -type DecryptionShareCombinator c = - EncryptedTally c -> [DecryptionShare c] -> Except ErrorTally [[DecryptionFactor c]] +type DecryptionShareCombinator crypto v c = + EncryptedTally crypto v c -> + [DecryptionShare crypto v c] -> + Except ErrorTally [[DecryptionFactor crypto c]] proveTally :: - Reifies c FFC => - (EncryptedTally c, Natural) -> [DecryptionShare c] -> - DecryptionShareCombinator c -> - Except ErrorTally (Tally c) + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Ord (FieldElement crypto c) => + (EncryptedTally crypto v c, Natural) -> [DecryptionShare crypto v c] -> + DecryptionShareCombinator crypto v c -> + Except ErrorTally (Tally crypto v c) proveTally (tally_encByChoiceByQuest, tally_countMax) tally_decShareByTrustee @@ -126,8 +156,12 @@ return Tally{..} verifyTally :: - Reifies c FFC => - Tally c -> DecryptionShareCombinator c -> + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Eq (FieldElement crypto c) => + Tally crypto v c -> + DecryptionShareCombinator crypto v c -> Except ErrorTally () verifyTally Tally{..} decShareCombinator = do decFactorByChoiceByQuest <- decShareCombinator tally_encByChoiceByQuest tally_decShareByTrustee @@ -144,11 +178,16 @@ -- ** Type 'DecryptionShare' -- | A decryption share is a 'DecryptionFactor' and a decryption 'Proof', by choice by 'Question'. -- Computed by a trustee in 'proveDecryptionShare'. -newtype DecryptionShare c = DecryptionShare - { unDecryptionShare :: [[(DecryptionFactor c, Proof c)]] } - deriving (Eq,Show,Generic) -deriving newtype instance NFData (DecryptionShare c) -instance ToJSON (DecryptionShare c) where +newtype DecryptionShare crypto v c = DecryptionShare + { unDecryptionShare :: [[(DecryptionFactor crypto c, Proof crypto v c)]] } + deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (DecryptionShare crypto v c) +deriving instance Show (G crypto c) => Show (DecryptionShare crypto v c) +deriving newtype instance NFData (FieldElement crypto c) => NFData (DecryptionShare crypto v c) +instance + ( Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (DecryptionShare crypto v c) where toJSON (DecryptionShare decByChoiceByQuest) = JSON.object [ "decryption_factors" .= @@ -162,7 +201,11 @@ (JSON.list (JSON.list (toEncoding . fst)) decByChoiceByQuest) <> JSON.pair "decryption_proofs" (JSON.list (JSON.list (toEncoding . snd)) decByChoiceByQuest) -instance Reifies c FFC => FromJSON (DecryptionShare c) where +instance + ( Reifies c crypto + , Group crypto + , FromJSON (G crypto c) + ) => FromJSON (DecryptionShare crypto v c) where parseJSON = JSON.withObject "DecryptionShare" $ \o -> do decFactors <- o .: "decryption_factors" decProofs <- o .: "decryption_proofs" @@ -179,21 +222,36 @@ -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare :: - Monad m => Reifies c FFC => RandomGen r => - EncryptedTally c -> SecretKey c -> S.StateT r m (DecryptionShare c) + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Key crypto => + ToNatural (FieldElement crypto c) => + Monad m => RandomGen r => + EncryptedTally crypto v c -> SecretKey crypto c -> S.StateT r m (DecryptionShare crypto v c) proveDecryptionShare encByChoiceByQuest trusteeSecKey = (DecryptionShare <$>) $ (proveDecryptionFactor trusteeSecKey `mapM`) `mapM` encByChoiceByQuest proveDecryptionFactor :: - Monad m => Reifies c FFC => RandomGen r => - SecretKey c -> Encryption c -> S.StateT r m (DecryptionFactor c, Proof c) + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Key crypto => + ToNatural (FieldElement crypto c) => + Monad m => RandomGen r => + SecretKey crypto c -> Encryption crypto v c -> S.StateT r m (DecryptionFactor crypto c, Proof crypto v c) proveDecryptionFactor trusteeSecKey Encryption{..} = do proof <- prove trusteeSecKey [groupGen, encryption_nonce] (hash zkp) return (encryption_nonce^trusteeSecKey, proof) where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: Reifies c FFC => PublicKey c -> BS.ByteString +decryptionShareStatement :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + PublicKey crypto c -> BS.ByteString decryptionShareStatement pubKey = "decrypt|"<>bytesNat pubKey<>"|" @@ -218,8 +276,13 @@ -- (supposedly submitted by a trustee whose 'PublicKey' is 'trusteePubKey') -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare :: - Monad m => Reifies c FFC => - EncryptedTally c -> PublicKey c -> DecryptionShare c -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + EncryptedTally crypto v c -> PublicKey crypto c -> DecryptionShare crypto v c -> ExceptT ErrorTally m () verifyDecryptionShare encByChoiceByQuest trusteePubKey (DecryptionShare decShare) = let zkp = decryptionShareStatement trusteePubKey in @@ -234,8 +297,13 @@ decShare verifyDecryptionShareByTrustee :: - Monad m => Reifies c FFC => - EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () verifyDecryptionShareByTrustee encTally = isoZipWithM_ (throwE ErrorTally_NumberOfTrustees) 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 @@ -12,9 +12,11 @@ import Data.Function (($)) import Data.Functor ((<$>)) import Data.Maybe (maybe) +import Data.Reflection (Reifies(..)) import Data.Semigroup (Semigroup(..)) import Data.Tuple (fst) import GHC.Generics (Generic) +import System.Random (RandomGen) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Aeson as JSON @@ -22,15 +24,15 @@ import qualified Data.List as List import Voting.Protocol.Utils -import Voting.Protocol.FFC +import Voting.Protocol.Arith import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally -- * Type 'TrusteePublicKey' -data TrusteePublicKey c = TrusteePublicKey - { trustee_PublicKey :: !(PublicKey c) - , trustee_SecretKeyProof :: !(Proof c) +data TrusteePublicKey crypto v c = TrusteePublicKey + { trustee_PublicKey :: !(PublicKey crypto c) + , trustee_SecretKeyProof :: !(Proof crypto v c) -- ^ NOTE: It is important to ensure -- that each trustee generates its key pair independently -- of the 'PublicKey's published by the other trustees. @@ -44,8 +46,14 @@ -- must 'prove' knowledge of the corresponding 'SecretKey'. -- Which is done in 'proveIndispensableTrusteePublicKey' -- and 'verifyIndispensableTrusteePublicKey'. - } deriving (Eq,Show,Generic,NFData) -instance ToJSON (TrusteePublicKey c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (TrusteePublicKey crypto v c) +deriving instance (Show (FieldElement crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (TrusteePublicKey crypto v c) +instance + ( Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (TrusteePublicKey crypto v c) where toJSON TrusteePublicKey{..} = JSON.object [ "pok" .= trustee_SecretKeyProof @@ -56,7 +64,11 @@ ( "pok" .= trustee_SecretKeyProof <> "public_key" .= trustee_PublicKey ) -instance Reifies c FFC => FromJSON (TrusteePublicKey c) where +instance + ( Reifies c crypto + , Group crypto + , FromJSON (PublicKey crypto c) + ) => FromJSON (TrusteePublicKey crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do trustee_PublicKey <- o .: "public_key" trustee_SecretKeyProof <- o .: "pok" @@ -68,8 +80,14 @@ -- returns the 'PublicKey' associated to 'trustSecKey' -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey :: - Reifies c FFC => Monad m => RandomGen r => - SecretKey c -> S.StateT r m (TrusteePublicKey c) + Reifies v Version => + Reifies c crypto => + Group crypto => + Key crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => RandomGen r => + SecretKey crypto c -> S.StateT r m (TrusteePublicKey crypto v c) proveIndispensableTrusteePublicKey trustSecKey = do let trustee_PublicKey = publicKey trustSecKey trustee_SecretKeyProof <- @@ -84,8 +102,13 @@ -- does 'prove' that the 'SecretKey' associated with -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey :: - Reifies c FFC => Monad m => - TrusteePublicKey c -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + TrusteePublicKey crypto v c -> ExceptT ErrorTrusteePublicKey m () verifyIndispensableTrusteePublicKey TrusteePublicKey{..} = unless ( @@ -102,7 +125,10 @@ deriving (Eq,Show) -- ** Hashing -indispensableTrusteePublicKeyStatement :: PublicKey c -> BS.ByteString +indispensableTrusteePublicKeyStatement :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + PublicKey crypto c -> BS.ByteString indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|" @@ -111,15 +137,23 @@ -- ** Generating an 'Election''s 'PublicKey' from multiple 'TrusteePublicKey's. combineIndispensableTrusteePublicKeys :: - Reifies c FFC => [TrusteePublicKey c] -> PublicKey c + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + [TrusteePublicKey crypto v c] -> PublicKey crypto c combineIndispensableTrusteePublicKeys = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one -- ** Checking the trustee's 'DecryptionShare's before decrypting an 'EncryptedTally'. verifyIndispensableDecryptionShareByTrustee :: - Reifies c FFC => Monad m => - EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () verifyIndispensableDecryptionShareByTrustee encByChoiceByQuest = isoZipWithM_ (throwE $ ErrorTally_NumberOfTrustees) @@ -130,7 +164,12 @@ -- | @('combineDecryptionShares' pubKeyByTrustee decShareByTrustee)@ -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares :: - Reifies c FFC => [PublicKey c] -> DecryptionShareCombinator c + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + [PublicKey crypto c] -> DecryptionShareCombinator crypto v c combineIndispensableDecryptionShares pubKeyByTrustee encByChoiceByQuest 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 @@ -2,12 +2,16 @@ import Control.Applicative (Applicative(..)) import Data.Bool +import Data.Either (Either(..), either) import Data.Eq (Eq(..)) import Data.Foldable (sequenceA_) -import Data.Function (($)) +import Data.Function (($), (.)) import Data.Functor ((<$)) import Data.Maybe (Maybe(..), maybe) +import Data.String (String) import Data.Traversable (Traversable(..)) +import Data.Tuple (uncurry) +import qualified Data.Aeson.Internal as JSON import qualified Data.List as List -- | Like ('.') but with two arguments. @@ -58,3 +62,8 @@ maybe err sequenceA_ $ isoZipWith3 f as bs cs +-- | 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 #-} diff --git a/tests/HUnit.hs b/tests/HUnit.hs --- a/tests/HUnit.hs +++ b/tests/HUnit.hs @@ -1,15 +1,16 @@ module HUnit where import Test.Tasty +import Voting.Protocol import qualified HUnit.FFC import qualified HUnit.Credential import qualified HUnit.Election import qualified HUnit.Trustee -hunits :: TestTree -hunits = +hunits :: Reifies v Version => Proxy v -> TestTree +hunits v = testGroup "HUnit" - [ HUnit.FFC.hunit - , HUnit.Credential.hunit - , HUnit.Election.hunit - , HUnit.Trustee.hunit + [ HUnit.FFC.hunit v + , HUnit.Credential.hunit v + , HUnit.Election.hunit v + , HUnit.Trustee.hunit v ] diff --git a/tests/HUnit/Credential.hs b/tests/HUnit/Credential.hs --- a/tests/HUnit/Credential.hs +++ b/tests/HUnit/Credential.hs @@ -8,8 +8,8 @@ import Voting.Protocol import Utils -hunit :: TestTree -hunit = testGroup "Credential" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit _v = testGroup "Credential" [ testGroup "randomCredential" [ testCase "0" $ S.evalState randomCredential (Random.mkStdGen 0) @?= @@ -42,8 +42,11 @@ ] ] -testSecretKey :: FFC -> UUID -> Credential -> Natural -> TestTree -testSecretKey ffc uuid cred exp = - reify ffc $ \(Proxy::Proxy c) -> +testSecretKey :: + ReifyCrypto crypto => + Key crypto => + crypto -> UUID -> Credential -> Natural -> TestTree +testSecretKey crypto uuid cred exp = + reifyCrypto crypto $ \(Proxy::Proxy c) -> testCase (show (uuid,cred)) $ - credentialSecretKey @c uuid cred @?= E exp + credentialSecretKey @_ @c uuid cred @?= E exp diff --git a/tests/HUnit/Election.hs b/tests/HUnit/Election.hs --- a/tests/HUnit/Election.hs +++ b/tests/HUnit/Election.hs @@ -4,6 +4,7 @@ module HUnit.Election where import Test.Tasty.HUnit +import qualified Data.Aeson as JSON import qualified Data.List as List import qualified Data.Text as Text import qualified System.Random as Random @@ -12,60 +13,65 @@ import Utils -hunit :: TestTree -hunit = testGroup "Election" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit v = testGroup "Election" $ [ testGroup "groupGenInverses" [ testCase "WeakParams" $ reify weakFFC $ \(Proxy::Proxy c) -> - List.take 10 (groupGenInverses @c) @?= + List.take 10 (groupGenInverses @_ @c) @?= [groupGen^neg (fromNatural n) | n <- [0..9]] , testCase "BeleniosParams" $ reify beleniosFFC $ \(Proxy::Proxy c) -> - List.take 10 (groupGenInverses @c) @?= + List.take 10 (groupGenInverses @_ @c) @?= [groupGen^neg (fromNatural n) | n <- [0..9]] ] , testGroup "encryptBallot" $ - [ testsEncryptBallot weakFFC - , testsEncryptBallot beleniosFFC + [ hunitsEncryptBallot v weakFFC + , hunitsEncryptBallot v beleniosFFC ] ] -testsEncryptBallot :: FFC -> TestTree -testsEncryptBallot ffc = - testGroup (Text.unpack $ ffc_name ffc) - [ testEncryptBallot ffc 0 +hunitsEncryptBallot :: + ReifyCrypto crypto => + JSON.ToJSON crypto => + Key crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +hunitsEncryptBallot v crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[True, False, False]] (Right True) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[False, False, False]] (Right True) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[False, False, False]] (Right True) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" [] zero one] [] (Left (ErrorBallot_WrongNumberOfAnswers 0 1)) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2"] one one] [[True]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[True, True, False]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] one one] [[False, False, False]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2"] one one] [[False, False, True]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [ Question "q1" ["a11","a12","a13"] zero (one+one) , Question "q2" ["a21","a22","a23"] one one ] @@ -74,26 +80,29 @@ (Right True) ] -testEncryptBallot :: - FFC -> Int -> [Question] -> [[Bool]] -> +hunitEncryptBallot :: + ReifyCrypto crypto => + JSON.ToJSON crypto => + Key crypto => + Reifies v Version => Proxy v -> + crypto -> Int -> [Question v] -> [[Bool]] -> Either ErrorBallot Bool -> TestTree -testEncryptBallot ffc seed quests opins exp = +hunitEncryptBallot v election_crypto seed election_questions opins exp = let got = - reify ffc $ \(Proxy::Proxy c) -> + reifyCrypto election_crypto $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - uuid <- randomUUID + election_uuid <- randomUUID cred <- randomCredential - let ballotSecKey = credentialSecretKey @c uuid cred - elecPubKey <- publicKey <$> randomSecretKey + let ballotSecKey = credentialSecretKey @_ @c election_uuid cred + election_public_key <- publicKey <$> randomSecretKey let elec = Election { election_name = "election" , election_description = "description" - , election_crypto = ElectionCrypto_FFC ffc elecPubKey - , election_questions = quests - , election_uuid = uuid , election_hash = hashElection elec + , election_version = Just (reflect v) + , .. } verifyBallot elec <$> encryptBallot elec (Just ballotSecKey) opins diff --git a/tests/HUnit/FFC.hs b/tests/HUnit/FFC.hs --- a/tests/HUnit/FFC.hs +++ b/tests/HUnit/FFC.hs @@ -6,41 +6,45 @@ import Test.Tasty.HUnit import Voting.Protocol import Utils +import qualified Data.Text as Text -hunit :: TestTree -hunit = testGroup "FFC" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit _v = testGroup "FFC" [ testGroup "inv" - [ testGroup "WeakParams" - [ testCase "groupGen" $ - reify weakFFC $ \(Proxy::Proxy c) -> - inv (groupGen @c) @?= - groupGen ^ E (fromJust $ groupOrder @c `minusNaturalMaybe` one) - ] - , testGroup "BeleniosParams" - [ testCase "groupGen" $ - reify beleniosFFC $ \(Proxy::Proxy c) -> - inv (groupGen @c) @?= - groupGen ^ E (fromJust $ groupOrder @c `minusNaturalMaybe` one) - ] + [ hunitInv weakFFC + , hunitInv beleniosFFC ] , testGroup "hash" [ testGroup "WeakParams" $ reify weakFFC $ \(Proxy::Proxy c) -> [ testCase "[groupGen]" $ - hash "start" [groupGen @c] @?= + hash "start" [groupGen :: G FFC c] @?= fromNatural 62 , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @c, groupGen] @?= + hash "start" [groupGen :: G FFC c, groupGen] @?= fromNatural 31 ] , testGroup "BeleniosParams" $ reify beleniosFFC $ \(Proxy::Proxy c) -> [ testCase "[groupGen]" $ - hash "start" [groupGen @c] @?= + hash "start" [groupGen :: G FFC c] @?= fromNatural 75778590284190557660612328423573274641033882642784670156837892421285248292707 , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @c, groupGen] @?= + hash "start" [groupGen :: G FFC c, groupGen] @?= fromNatural 28798937720387703653439047952832768487958170248947132321730024269734141660223 ] ] ] + +hunitInv :: + forall crypto. + ReifyCrypto crypto => + Key crypto => + crypto -> TestTree +hunitInv crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ testCase "groupGen" $ + reifyCrypto crypto $ \(_c::Proxy c) -> + inv (groupGen :: G crypto c) @?= + groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) + ] diff --git a/tests/HUnit/Trustee.hs b/tests/HUnit/Trustee.hs --- a/tests/HUnit/Trustee.hs +++ b/tests/HUnit/Trustee.hs @@ -1,9 +1,10 @@ module HUnit.Trustee where import Test.Tasty +import Voting.Protocol import qualified HUnit.Trustee.Indispensable -hunit :: TestTree -hunit = +hunit :: Reifies v Version => Proxy v -> TestTree +hunit v = testGroup "Trustee" - [ HUnit.Trustee.Indispensable.hunit + [ HUnit.Trustee.Indispensable.hunit v ] 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 @@ -12,61 +12,77 @@ import Utils -hunit :: TestTree -hunit = testGroup "Indispensable" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit v = testGroup "Indispensable" $ [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testsVerifyIndispensableTrusteePublicKey weakFFC + [ testsVerifyIndispensableTrusteePublicKey v weakFFC ] , testGroup "verifyTally" $ - [ testsVerifyTally weakFFC - , testsVerifyTally beleniosFFC + [ testsVerifyTally v weakFFC + , testsVerifyTally v beleniosFFC ] ] -testsVerifyIndispensableTrusteePublicKey :: FFC -> TestTree -testsVerifyIndispensableTrusteePublicKey ffc = - testGroup (Text.unpack $ ffc_name ffc) - [ testVerifyIndispensableTrusteePublicKey ffc 0 (Right ()) +testsVerifyIndispensableTrusteePublicKey :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +testsVerifyIndispensableTrusteePublicKey v crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ testVerifyIndispensableTrusteePublicKey v crypto 0 (Right ()) ] testVerifyIndispensableTrusteePublicKey :: - FFC -> Int -> Either ErrorTrusteePublicKey () -> TestTree -testVerifyIndispensableTrusteePublicKey ffc seed exp = + forall crypto v. + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> Int -> Either ErrorTrusteePublicKey () -> TestTree +testVerifyIndispensableTrusteePublicKey (_v::Proxy v) crypto seed exp = + reifyCrypto crypto $ \(Proxy::Proxy c) -> let got = - reify ffc $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - trusteeSecKey :: SecretKey c <- randomSecretKey - trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey + trusteeSecKey :: SecretKey crypto c <- randomSecretKey + trusteePubKey :: TrusteePublicKey crypto v c <- proveIndispensableTrusteePublicKey trusteeSecKey lift $ verifyIndispensableTrusteePublicKey trusteePubKey in - testCase (Text.unpack $ ffc_name ffc) $ + testCase (Text.unpack $ cryptoName crypto) $ got @?= exp -testsVerifyTally :: FFC -> TestTree -testsVerifyTally ffc = - testGroup (Text.unpack $ ffc_name ffc) - [ testVerifyTally ffc 0 1 1 1 - , testVerifyTally ffc 0 2 1 1 - , testVerifyTally ffc 0 1 2 1 - , testVerifyTally ffc 0 2 2 1 - , testVerifyTally ffc 0 5 10 5 +testsVerifyTally :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +testsVerifyTally v crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ testVerifyTally v crypto 0 1 1 1 + , testVerifyTally v crypto 0 2 1 1 + , testVerifyTally v crypto 0 1 2 1 + , testVerifyTally v crypto 0 2 2 1 + , testVerifyTally v crypto 0 5 10 5 ] -testVerifyTally :: FFC -> Int -> Natural -> Natural -> Natural -> TestTree -testVerifyTally ffc seed nTrustees nQuests nChoices = +testVerifyTally :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> Int -> Natural -> Natural -> Natural -> TestTree +testVerifyTally (_v::Proxy v) crypto seed nTrustees nQuests nChoices = let clearTallyResult = dummyTallyResult nQuests nChoices in let decryptedTallyResult :: Either ErrorTally [[Natural]] = - reify ffc $ \(Proxy::Proxy c) -> + reifyCrypto crypto $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - secKeyByTrustee :: [SecretKey c] <- + secKeyByTrustee :: [SecretKey crypto c] <- replicateM (fromIntegral nTrustees) $ randomSecretKey - trusteePubKeys <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey + trusteePubKeys + :: [TrusteePublicKey crypto v c] + <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey let pubKeyByTrustee = trustee_PublicKey <$> trusteePubKeys let elecPubKey = combineIndispensableTrusteePublicKeys trusteePubKeys (encTally, countMax) <- encryptTallyResult elecPubKey clearTallyResult - decShareByTrustee <- forM secKeyByTrustee $ proveDecryptionShare encTally + decShareByTrustee + :: [DecryptionShare crypto v c] + <- forM secKeyByTrustee $ proveDecryptionShare encTally lift $ verifyDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee tally@Tally{..} <- lift $ proveTally (encTally, countMax) decShareByTrustee $ @@ -90,9 +106,12 @@ ] encryptTallyResult :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> [[Natural]] -> StateT r m (EncryptedTally c, Natural) + PublicKey crypto c -> [[Natural]] -> StateT r m (EncryptedTally crypto v c, Natural) encryptTallyResult pubKey countByChoiceByQuest = (`runStateT` 0) $ forM countByChoiceByQuest $ diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,15 +1,17 @@ module Main where -import System.IO (IO) import Data.Function (($)) -import Test.Tasty -import QuickCheck import HUnit +import QuickCheck +import System.IO (IO) +import Test.Tasty +import Voting.Protocol main :: IO () main = defaultMain $ - testGroup "Protocol" - [ hunits - , quickchecks + reify stableVersion $ \v -> + testGroup "Voting.Protocol" + [ hunits v + , quickchecks v ] diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -1,11 +1,12 @@ module QuickCheck where import Test.Tasty +import Voting.Protocol import qualified QuickCheck.Election import qualified QuickCheck.Trustee -quickchecks :: TestTree -quickchecks = +quickchecks :: Reifies v Version => Proxy v -> TestTree +quickchecks v = testGroup "QuickCheck" - [ QuickCheck.Election.quickcheck - , QuickCheck.Trustee.quickcheck + [ QuickCheck.Election.quickcheck v + , QuickCheck.Trustee.quickcheck v ] diff --git a/tests/QuickCheck/Election.hs b/tests/QuickCheck/Election.hs --- a/tests/QuickCheck/Election.hs +++ b/tests/QuickCheck/Election.hs @@ -10,6 +10,7 @@ import GHC.Natural (minusNaturalMaybe) import Prelude (undefined) import Test.Tasty.QuickCheck +import qualified Data.Aeson as JSON import qualified Data.List as List import qualified Data.Text as Text @@ -23,20 +24,23 @@ maxArbitraryQuestions :: Natural maxArbitraryQuestions = 2 -quickcheck :: TestTree -quickcheck = +quickcheck :: Reifies v Version => Proxy v -> TestTree +quickcheck v = testGroup "Election" [ testGroup "verifyBallot" $ - [ testElection weakFFC - , testElection beleniosFFC + [ quickcheckElection v weakFFC + , quickcheckElection v beleniosFFC ] ] -testElection :: FFC -> TestTree -testElection ffc = - reify ffc $ \(Proxy::Proxy c) -> - testGroup (Text.unpack $ ffc_name ffc) - [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) -> +quickcheckElection :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +quickcheckElection (_v::Proxy v) crypto = + reifyCrypto crypto $ \(Proxy::Proxy c) -> + testGroup (Text.unpack $ cryptoName crypto) + [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do -- ballotSecKey :: SecretKey c <- randomSecretKey @@ -47,23 +51,34 @@ instance Reifies c FFC => Arbitrary (F c) where arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one) -instance Reifies c FFC => Arbitrary (G c) where +instance + ( Reifies c crypto + , Group crypto + , Multiplicative (FieldElement crypto c) + ) => Arbitrary (G crypto c) where arbitrary = do m <- arbitrary return (groupGen ^ m) -instance Reifies c FFC => Arbitrary (E c) where - arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one) +instance + ( Reifies c crypto + , Group crypto + ) => Arbitrary (E crypto c) where + arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one) instance Arbitrary UUID where arbitrary = do seed <- arbitrary (`evalStateT` mkStdGen seed) $ randomUUID -instance Reifies c FFC => Arbitrary (Proof c) where +instance + ( Reifies v Version + , Reifies c crypto + , Arbitrary (E crypto c) + ) => Arbitrary (Proof crypto v c) where arbitrary = do proof_challenge <- arbitrary proof_response <- arbitrary return Proof{..} -instance Arbitrary Question where +instance Reifies v Version => Arbitrary (Question v) where arbitrary = do let question_text = "question" choices :: Natural <- choose (1, maxArbitraryChoices) @@ -78,16 +93,26 @@ , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest ] -instance Reifies c FFC => Arbitrary (Election c) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , Key crypto + , Multiplicative (FieldElement crypto c) + , JSON.ToJSON crypto + , JSON.ToJSON (FieldElement crypto c) + ) => Arbitrary (Election crypto v c) where arbitrary = do let election_name = "election" let election_description = "description" - election_crypto <- arbitrary + let election_crypto = reflect (Proxy @c) + election_secret_key <- arbitrary + let election_public_key = publicKey election_secret_key election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary election_uuid <- arbitrary - let elec = - Election - { election_hash = hashElection elec + let elec = Election + { election_hash = hashElection elec + , election_version = Just (reflect (Proxy @v)) , .. } return elec @@ -95,16 +120,18 @@ [ elec{election_questions} | election_questions <- shrink $ election_questions elec ] +{- instance Reifies c FFC => Arbitrary (ElectionCrypto c) where arbitrary = do let electionCrypto_FFC_params = reflect (Proxy::Proxy c) electionCrypto_FFC_PublicKey <- arbitrary return ElectionCrypto_FFC{..} +-} -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@. data (:>) a b = a :> b deriving (Eq,Show) -instance Arbitrary (Question :> [Bool]) where +instance Reifies v Version => Arbitrary (Question v :> [Bool]) where arbitrary = do quest@Question{..} <- arbitrary votes <- do @@ -117,7 +144,15 @@ [ q :> shrinkVotes q votes | q <- shrink quest ] -instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , Key crypto + , JSON.ToJSON crypto + , JSON.ToJSON (FieldElement crypto c) + , Multiplicative (FieldElement crypto c) + ) => Arbitrary (Election crypto v c :> [[Bool]]) where arbitrary = do elec@Election{..} <- arbitrary votes <- forM election_questions $ \Question{..} -> do @@ -127,7 +162,7 @@ return $ boolsOfCombin numChoices numTrue rank return (elec :> votes) shrink (elec :> votes) = - [ e :> List.zipWith shrinkVotes (election_questions e) votes + [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes | e <- shrink elec ] @@ -149,7 +184,7 @@ -- | @('shrinkVotes' quest votes)@ -- returns a reduced version of the given @votes@ -- to fit the requirement of the given @quest@. -shrinkVotes :: Question -> [Bool] -> [Bool] +shrinkVotes :: Reifies v Version => Question v -> [Bool] -> [Bool] shrinkVotes Question{..} votes = (\(nTrue, b) -> nTrue <= nat question_maxi && b) <$> List.zip (countTrue votes) votes @@ -159,4 +194,3 @@ where inc [] = [zero] inc (n:ns) = (n+one):n:ns - diff --git a/tests/QuickCheck/Trustee.hs b/tests/QuickCheck/Trustee.hs --- a/tests/QuickCheck/Trustee.hs +++ b/tests/QuickCheck/Trustee.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module QuickCheck.Trustee where @@ -10,28 +11,37 @@ import Utils import QuickCheck.Election () -quickcheck :: TestTree -quickcheck = - testGroup "Trustee" +quickcheck :: Reifies v Version => Proxy v -> TestTree +quickcheck v = + testGroup "Trustee" $ [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testIndispensableTrusteePublicKey weakFFC - , testIndispensableTrusteePublicKey beleniosFFC + [ testIndispensableTrusteePublicKey v weakFFC + , testIndispensableTrusteePublicKey v beleniosFFC ] ] -testIndispensableTrusteePublicKey :: FFC -> TestTree -testIndispensableTrusteePublicKey ffc = - reify ffc $ \(Proxy::Proxy c) -> - testGroup (Text.unpack $ ffc_name ffc) +testIndispensableTrusteePublicKey :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +testIndispensableTrusteePublicKey (_v::Proxy v) crypto = + reifyCrypto crypto $ \(Proxy::Proxy c) -> + testGroup (Text.unpack $ cryptoName crypto) [ testProperty "Right" $ \seed -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do - trusteeSecKey :: SecretKey c <- randomSecretKey - trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey + trusteeSecKey :: SecretKey crypto c <- randomSecretKey + trusteePubKey :: TrusteePublicKey crypto v c + <- proveIndispensableTrusteePublicKey trusteeSecKey lift $ verifyIndispensableTrusteePublicKey trusteePubKey ] -instance Reifies c FFC => Arbitrary (TrusteePublicKey c) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , Multiplicative (FieldElement crypto c) + ) => Arbitrary (TrusteePublicKey crypto v c) where arbitrary = do trustee_PublicKey <- arbitrary trustee_SecretKeyProof <- arbitrary