diff --git a/benchmarks/Election.hs b/benchmarks/Election.hs --- a/benchmarks/Election.hs +++ b/benchmarks/Election.hs @@ -8,15 +8,15 @@ import Voting.Protocol import Utils -makeElection :: SubGroup q => Int -> Int -> Election q -makeElection nQuests nChoices = Election +makeElection :: forall c. Reifies c FFC => Int -> Int -> Election c +makeElection nQuests nChoices = hashElection $ Election { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices , election_description = "benchmarkable election" , election_uuid - , election_PublicKey = + , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $ let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in publicKey secKey - , election_hash = Hash "" -- FIXME: when implemented + , election_hash = Hash "" , election_questions = (<$> [1..nQuests]) $ \quest -> Question { question_text = Text.pack $ "quest"<>show quest @@ -26,16 +26,16 @@ } } where election_uuid = UUID "xLcs7ev6Jy6FHH" -makeVotes :: Election q -> [[Bool]] +makeVotes :: Election c -> [[Bool]] makeVotes Election{..} = [ True : List.tail [ False | _choice <- question_choices quest ] | quest <- election_questions ] -makeBallot :: forall q. SubGroup q => Election q -> Ballot q +makeBallot :: Reifies c FFC => Election c -> Ballot c makeBallot elec = case runExcept $ (`evalStateT` mkStdGen seed) $ do - ballotSecKey :: SecretKey q <- randomSecretKey + ballotSecKey <- randomSecretKey encryptBallot elec (Just ballotSecKey) $ makeVotes elec of Right ballot -> ballot @@ -43,7 +43,7 @@ where seed = 0 -titleElection :: Election q -> String +titleElection :: Election c -> String titleElection Election{..} = Printf.printf "(questions=%i)×(choices=%i)==%i" nQuests nChoices (nQuests * nChoices) @@ -51,26 +51,26 @@ nQuests = List.length election_questions nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions -benchEncryptBallot :: forall q. Params q => Int -> Int -> Benchmark -benchEncryptBallot nQuests nChoices = - env setupEnv $ \ ~elec -> - bench (titleElection elec) $ - nf makeBallot elec - where - setupEnv = do - let elec :: Election q = makeElection nQuests nChoices - return elec +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 -benchVerifyBallot :: forall q. Params q => Int -> Int -> Benchmark -benchVerifyBallot nQuests nChoices = - env setupEnv $ \ ~(elec,ballot) -> - bench (titleElection elec) $ - nf (verifyBallot elec) ballot - where - setupEnv = do - let elec :: Election q = makeElection nQuests nChoices - let ballot = makeBallot elec - return (elec,ballot) +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 benchmarks :: [Benchmark] benchmarks = @@ -79,23 +79,23 @@ | nQ <- [1,5,10,15,20,25] , nC <- [5,7] ] in - [ bgroup "WeakParams" + [ bgroup "weakFFC" [ bgroup "encryptBallot" - [ benchEncryptBallot @WeakParams nQuests nChoices + [ benchEncryptBallot weakFFC nQuests nChoices | (nQuests,nChoices) <- inputs ] , bgroup "verifyBallot" - [ benchVerifyBallot @WeakParams nQuests nChoices + [ benchVerifyBallot weakFFC nQuests nChoices | (nQuests,nChoices) <- inputs ] ] - , bgroup "BeleniosParams" + , bgroup "beleniosFFC" [ bgroup "encryptBallot" - [ benchEncryptBallot @BeleniosParams nQuests nChoices + [ benchEncryptBallot beleniosFFC nQuests nChoices | (nQuests,nChoices) <- inputs ] , bgroup "verifyBallot" - [ benchVerifyBallot @BeleniosParams nQuests nChoices + [ benchVerifyBallot beleniosFFC nQuests nChoices | (nQuests,nChoices) <- inputs ] ] diff --git a/benchmarks/Utils.hs b/benchmarks/Utils.hs --- a/benchmarks/Utils.hs +++ b/benchmarks/Utils.hs @@ -16,8 +16,6 @@ , Text , Word8 , Num, Fractional(..), Integral(..), Integer, fromIntegral - , min - , max , Show(..) , MonadTrans(..) , ExceptT @@ -50,7 +48,7 @@ import Data.Text (Text) import Data.Word (Word8) import Debug.Trace -import Prelude (Num(..), Fractional(..), Integral(..), Integer, undefined, fromIntegral, error) +import Prelude (Num(..), Fractional(..), Integral(..), Integer, fromIntegral, error) import System.IO (IO) import System.Random (mkStdGen) import Text.Show (Show(..)) 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.0.20190513 +version: 0.0.0.20190519 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: @@ -17,9 +17,6 @@ and Malika Izabachène. . - (TODO) Actually, this protocol is adapted a little bit here to better support - a better method of voting known as the . - . * A large-public introduction (in french) to Helios-C is available here: . * A more scientific (yet understandable) introduction (in english) to Belenios @@ -64,7 +61,7 @@ hs-source-dirs: src exposed-modules: Voting.Protocol - Voting.Protocol.Arithmetic + Voting.Protocol.FFC Voting.Protocol.Credential Voting.Protocol.Election Voting.Protocol.Tally @@ -87,11 +84,11 @@ NoMonomorphismRestriction RecordWildCards ScopedTypeVariables + StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators - UndecidableInstances ghc-options: -Wall -Wincomplete-uni-patterns @@ -100,6 +97,9 @@ -- -fhide-source-paths build-depends: base >= 4.6 && < 5 + , aeson >= 1.3 + , base64-bytestring >= 1.0 + , binary >= 0.8 , bytestring >= 0.10 , containers >= 0.5 , cryptonite >= 0.25 @@ -110,7 +110,7 @@ -- , monad-classes >= 0.3 , deepseq >= 1.4 , random >= 1.1 - -- , reflection >= 2.1 + , reflection >= 2.1 , text >= 1.2 , transformers >= 0.5 , unordered-containers >= 0.2.8 @@ -121,7 +121,7 @@ main-is: Main.hs other-modules: HUnit - HUnit.Arithmetic + HUnit.FFC HUnit.Credential HUnit.Election HUnit.Trustee @@ -146,11 +146,11 @@ NoMonomorphismRestriction RecordWildCards ScopedTypeVariables + StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators - UndecidableInstances ghc-options: -Wall -Wincomplete-uni-patterns @@ -160,6 +160,7 @@ build-depends: hjugement-protocol , base >= 4.6 && < 5 + , aeson >= 1.3 , containers >= 0.5 -- , hashable >= 1.2.6 , QuickCheck >= 2.11 @@ -196,11 +197,11 @@ NoMonomorphismRestriction RecordWildCards ScopedTypeVariables + StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators - UndecidableInstances ghc-options: -Wall -Wincomplete-uni-patterns diff --git a/src/Voting/Protocol.hs b/src/Voting/Protocol.hs --- a/src/Voting/Protocol.hs +++ b/src/Voting/Protocol.hs @@ -1,12 +1,12 @@ module Voting.Protocol - ( module Voting.Protocol.Arithmetic + ( module Voting.Protocol.FFC , module Voting.Protocol.Credential , module Voting.Protocol.Election , module Voting.Protocol.Tally , module Voting.Protocol.Trustee ) where -import Voting.Protocol.Arithmetic +import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally diff --git a/src/Voting/Protocol/Arithmetic.hs b/src/Voting/Protocol/Arithmetic.hs deleted file mode 100644 --- a/src/Voting/Protocol/Arithmetic.hs +++ /dev/null @@ -1,335 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Voting.Protocol.Arithmetic - ( module Voting.Protocol.Arithmetic - , Natural - , Random.RandomGen - ) where - -import Control.Arrow (first) -import Control.DeepSeq (NFData) -import Control.Monad (Monad(..)) -import Data.Bits -import Data.Bool -import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldl') -import Data.Function (($), (.)) -import Data.Functor ((<$>)) -import Data.Int (Int) -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord(..)) -import Data.Semigroup (Semigroup(..)) -import Data.String (String, IsString(..)) -import Numeric.Natural (Natural) -import Prelude (Integer, Integral(..), fromIntegral, Enum(..)) -import Text.Show (Show(..)) -import qualified Control.Monad.Trans.State.Strict as S -import qualified Crypto.Hash as Crypto -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS -import qualified Data.List as List -import qualified Prelude as Num -import qualified System.Random as Random - --- * Type 'F' --- | The type of the elements of a 'PrimeField'. --- --- A field must satisfy the following properties: --- --- * @(f, ('+'), 'zero')@ forms an abelian group, --- called the 'Additive' group of 'f'. --- --- * @('NonNull' f, ('*'), 'one')@ forms an abelian group, --- called the 'Multiplicative' group of 'f'. --- --- * ('*') is associative: --- @(a'*'b)'*'c == a'*'(b'*'c)@ and --- @a'*'(b'*'c) == (a'*'b)'*'c@. --- --- * ('*') and ('+') are both commutative: --- @a'*'b == b'*'a@ and --- @a'+'b == b'+'a@ --- --- * ('*') and ('+') are both left and right distributive: --- @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and --- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@ --- --- The 'Natural' is always within @[0..'fieldCharac'-1]@. -newtype F p = F { unF :: Natural } - deriving (Eq,Ord,Show,NFData) - -instance PrimeField p => FromNatural (F p) where - fromNatural i = F (abs (i `mod` fieldCharac @p)) - where abs x | x < 0 = x + fieldCharac @p - | otherwise = x -instance ToNatural (F p) where - nat = unF - -instance PrimeField p => Additive (F p) where - zero = F 0 - F x + F y = F ((x + y) `mod` fieldCharac @p) -instance PrimeField p => Negable (F p) where - neg (F x) | x == 0 = zero - | otherwise = F (fromIntegral (Num.negate (toInteger x) + toInteger (fieldCharac @p))) -instance PrimeField p => Multiplicative (F p) where - one = F 1 - -- | Because 'fieldCharac' is prime, - -- all elements of the field are invertible modulo 'fieldCharac'. - F x * F y = F ((x * y) `mod` fieldCharac @p) -instance PrimeField p => Random.Random (F p) where - randomR (F lo, F hi) = - first (F . fromIntegral) . - Random.randomR - ( 0`max`toInteger lo - , toInteger hi`min`(toInteger (fieldCharac @p) - 1)) - random = first (F . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @p) - 1) - --- ** Class 'PrimeField' --- | Parameter for a prime field. -class PrimeField p where - -- | The prime number characteristic of a 'PrimeField'. - -- - -- ElGamal's hardness to decrypt requires a large prime number - -- to form the 'Multiplicative' 'SubGroup'. - fieldCharac :: Natural - --- ** 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 'PrimeField'. -newtype G q = G { unG :: F (P q) } - deriving (Eq,Ord,Show,NFData) - -instance PrimeField (P q) => FromNatural (G q) where - fromNatural = G . fromNatural -instance ToNatural (G q) where - nat = unF . unG - -instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (G q) where - one = G one - G x * G y = G (x * y) -instance (SubGroup q, Multiplicative (F (P q))) => Invertible (G q) where - -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. - inv = (^ E (neg one + groupOrder @q)) - --- ** Class 'SubGroup' --- | A 'SubGroup' of a 'Multiplicative' group of a 'PrimeField'. --- Used for signing (Schnorr) and encrypting (ElGamal). -class - ( PrimeField (P q) - , Multiplicative (F (P q)) - ) => SubGroup q where - -- | Setting 'q' determines 'p', equals to @'P' q@. - type P q :: * - -- | A generator of the 'SubGroup'. - -- NOTE: since @F p@ is a 'PrimeField', - -- the 'Multiplicative' 'SubGroup' is cyclic, - -- and there are phi('fieldCharac'-1) many choices for the generator of the group, - -- where phi is the Euler totient function. - groupGen :: G q - -- | The order of the 'SubGroup'. - -- - -- WARNING: 'groupOrder' MUST be a prime number dividing @('fieldCharac'-1)@ - -- to ensure that ElGamal is secure in terms of the DDH assumption. - groupOrder :: F (P q) - - -- | 'groupGenInverses' returns the infinite list - -- of 'inv'erse powers of 'groupGen': - -- @['groupGen' '^' 'neg' i | i <- [0..]]@, - -- but by computing each value from the previous one. - -- - -- NOTE: 'groupGenInverses' is in the 'SubGroup' class in order to keep - -- computed terms in memory across calls to 'groupGenInverses'. - -- - -- Used by 'intervalDisjunctions'. - groupGenInverses :: [G q] - groupGenInverses = go one - where - go g = g : go (g * invGen) - invGen = inv groupGen - -groupGenPowers :: SubGroup q => [G q] -groupGenPowers = go one - where go g = g : go (g * groupGen) - --- | @('hash' bs gs)@ returns as a number in 'E' --- the SHA256 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 :: SubGroup q => BS.ByteString -> [G q] -> E q -hash bs gs = - let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs) in - let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) in - fromNatural (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h) - --- * Type 'E' --- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'. --- The value is always in @[0..'groupOrder'-1]@. -newtype E q = E { unE :: F (P q) } - deriving (Eq,Ord,Show,NFData) - -instance SubGroup q => FromNatural (E q) where - fromNatural i = E (F (abs (i `mod` unF (groupOrder @q)))) - where abs x | x < 0 = x + unF (groupOrder @q) - | otherwise = x -instance ToNatural (E q) where - nat = unF . unE - -instance (SubGroup q, Additive (F (P q))) => Additive (E q) where - zero = E zero - E (F x) + E (F y) = E (F ((x + y) `mod` unF (groupOrder @q))) -instance (SubGroup q, Negable (F (P q))) => Negable (E q) where - neg (E (F x)) | x == 0 = zero - | otherwise = E (F (fromIntegral ( neg (toInteger x) - + toInteger (unF (groupOrder @q)) ))) -instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (E q) where - one = E one - E (F x) * E (F y) = E (F ((x * y) `mod` unF (groupOrder @q))) -instance SubGroup q => Random.Random (E q) where - randomR (E (F lo), E (F hi)) = - first (E . F . fromIntegral) . - Random.randomR - ( 0`max`toInteger lo - , toInteger hi`min`(toInteger (unF (groupOrder @q)) - 1) ) - random = - first (E . F . fromIntegral) . - Random.randomR (0, toInteger (unF (groupOrder @q)) - 1) -instance SubGroup q => Enum (E q) 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'. -(^) :: SubGroup q => G q -> E q -> G q -(^) b (E (F e)) - | e == zero = one - | otherwise = t * (b*b) ^ E (F (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 - --- * Groups - --- * Type 'Params' -class SubGroup q => Params q where - paramsName :: String -instance Params WeakParams where - paramsName = "WeakParams" -instance Params BeleniosParams where - paramsName = "BeleniosParams" - --- ** Type 'WeakParams' --- | Weak parameters for debugging purposes only. -data WeakParams -instance PrimeField WeakParams where - fieldCharac = 263 -instance SubGroup WeakParams where - type P WeakParams = WeakParams - groupGen = G (F 2) - groupOrder = F 131 - --- ** Type 'BeleniosParams' --- | Parameters used in Belenios. --- A 2048-bit 'fieldCharac' of a 'PrimeField', --- with a 256-bit 'groupOrder' for a 'Multiplicative' 'SubGroup' --- generated by 'groupGen'. -data BeleniosParams -instance PrimeField BeleniosParams where - fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719 -instance SubGroup BeleniosParams where - type P BeleniosParams = BeleniosParams - groupGen = G (F 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627) - groupOrder = F 78571733251071885079927659812671450121821421258408794611510081919805623223441 - --- * Conversions - --- ** Class 'FromNatural' -class FromNatural a where - fromNatural :: Natural -> a - --- ** Class 'ToNatural' -class ToNatural a where - nat :: a -> Natural - --- | @('bytesNat' x)@ returns the serialization of 'x'. -bytesNat :: ToNatural n => n -> BS.ByteString -bytesNat = fromString . show . nat diff --git a/src/Voting/Protocol/Credential.hs b/src/Voting/Protocol/Credential.hs --- a/src/Voting/Protocol/Credential.hs +++ b/src/Voting/Protocol/Credential.hs @@ -1,26 +1,30 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} module Voting.Protocol.Credential where import Control.DeepSeq (NFData) -import Control.Monad (Monad(..), replicateM) +import Control.Monad (Monad(..), forM_, replicateM) import Data.Bits import Data.Bool import Data.Char (Char) -import Data.Either (Either(..)) +import Data.Either (Either(..), either) import Data.Eq (Eq(..)) import Data.Function (($)) import Data.Functor ((<$>)) import Data.Int (Int) import Data.Maybe (maybe) import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Prelude (Integral(..), fromIntegral, div) -import Text.Show (Show) +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.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.Char as Char @@ -29,7 +33,7 @@ import qualified Data.Text.Encoding as Text import qualified System.Random as Random -import Voting.Protocol.Arithmetic +import Voting.Protocol.FFC -- * Type 'Credential' -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters @@ -39,7 +43,14 @@ -- The last character is a checksum. -- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@. newtype Credential = Credential Text - deriving (Eq,Show,Generic,NFData) + deriving (Eq,Show,Generic) + deriving newtype NFData + deriving newtype JSON.ToJSON +instance JSON.FromJSON Credential where + parseJSON json@(JSON.String s) = + either (\err -> JSON.typeMismatch ("Credential: "<>show err) json) return $ + readCredential s + parseJSON json = JSON.typeMismatch "Credential" json credentialAlphabet :: [Char] -- TODO: make this an array credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" @@ -63,9 +74,9 @@ -- | @'readCredential'@ reads and check the well-formedness of a 'Credential' -- from raw 'Text'. -readCredential :: Text -> Either CredentialError Credential +readCredential :: Text -> Either ErrorToken Credential readCredential s - | Text.length s /= tokenLength + 1 = Left CredentialError_Length + | Text.length s /= tokenLength + 1 = Left ErrorToken_Length | otherwise = do tot <- Text.foldl' (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c) @@ -74,22 +85,29 @@ checksum <- digitOfChar (Text.last s) if (tot + checksum) `mod` 53 == 0 then Right (Credential s) - else Left CredentialError_Checksum + else Left ErrorToken_Checksum where digitOfChar c = - maybe (Left $ CredentialError_BadChar c) Right $ + maybe (Left $ ErrorToken_BadChar c) Right $ List.elemIndex c credentialAlphabet --- ** Type 'CredentialError' -data CredentialError - = CredentialError_BadChar Char.Char - | CredentialError_Checksum - | CredentialError_Length +-- ** Type 'ErrorToken' +data ErrorToken + = ErrorToken_BadChar Char.Char + | ErrorToken_Checksum + | ErrorToken_Length deriving (Eq,Show,Generic,NFData) -- ** Type 'UUID' newtype UUID = UUID Text - deriving (Eq,Ord,Show,Generic,NFData) + deriving (Eq,Ord,Show,Generic) + deriving anyclass (JSON.ToJSON) + deriving newtype NFData +instance JSON.FromJSON UUID where + parseJSON json@(JSON.String s) = + either (\err -> JSON.typeMismatch ("UUID: "<>show err) json) return $ + readUUID s + parseJSON json = JSON.typeMismatch "UUID" json -- | @'randomUUID'@ generates a random 'UUID'. randomUUID :: @@ -102,16 +120,29 @@ where charOfDigit = (credentialAlphabet List.!!) +-- | @'readCredential'@ reads and check the well-formedness of a 'Credential' +-- from raw 'Text'. +readUUID :: Text -> Either ErrorToken UUID +readUUID s + | Text.length s /= tokenLength = Left ErrorToken_Length + | otherwise = do + forM_ (Text.unpack s) digitOfChar + return (UUID s) + where + digitOfChar c = + maybe (Left $ ErrorToken_BadChar c) Right $ + List.elemIndex c credentialAlphabet + -- ** Type 'SecretKey' type SecretKey = E -randomSecretKey :: Monad m => RandomGen r => SubGroup q => S.StateT r m (SecretKey q) +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 :: SubGroup q => UUID -> Credential -> SecretKey q +credentialSecretKey :: Reifies c FFC => UUID -> Credential -> (SecretKey c) credentialSecretKey (UUID uuid) (Credential cred) = fromNatural $ BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) @@ -132,6 +163,6 @@ type PublicKey = G -- | @('publicKey' secKey)@ returns the 'PublicKey' --- derived from given 'SecretKey'. -publicKey :: SubGroup q => SecretKey q -> PublicKey q +-- 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,36 +2,44 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} -- for reifyElection +{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Election where +import Control.Applicative (Applicative(..)) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT, runExcept, throwE, withExceptT) +import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.=)) import Data.Bool import Data.Either (either) import Data.Eq (Eq(..)) import Data.Foldable (Foldable, foldMap, and) -import Data.Function (($), id, const) +import Data.Function (($), (.), id, const) import Data.Functor (Functor, (<$>)) import Data.Functor.Identity (Identity(..)) -import Data.Maybe (Maybe(..), fromMaybe) +import Data.Maybe (Maybe(..), fromJust) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd) -import GHC.Natural (minusNaturalMaybe) import GHC.Generics (Generic) +import GHC.Natural (minusNaturalMaybe) import Numeric.Natural (Natural) import Prelude (fromIntegral) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S +import qualified Data.Aeson as JSON import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.Lazy as BSL64 import qualified Data.List as List +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import Voting.Protocol.Utils -import Voting.Protocol.Arithmetic +import Voting.Protocol.FFC import Voting.Protocol.Credential -- * Type 'Encryption' @@ -46,18 +54,20 @@ -- -- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@, -- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@. -data Encryption q = Encryption - { encryption_nonce :: G q +data Encryption c = Encryption + { encryption_nonce :: !(G c) -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text, -- equal to @('groupGen' '^'encNonce)@ - , encryption_vault :: G q + , encryption_vault :: !(G c) -- ^ Encrypted 'clear' text, -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ } deriving (Eq,Show,Generic,NFData) +deriving instance Reifies c FFC => ToJSON (Encryption c) +deriving instance Reifies c FFC => FromJSON (Encryption c) -- | Additive homomorphism. -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. -instance SubGroup q => Additive (Encryption q) where +instance Reifies c FFC => Additive (Encryption c) where zero = Encryption one one x+y = Encryption (encryption_nonce x * encryption_nonce y) @@ -75,9 +85,10 @@ -- as it may be used to decipher the 'Encryption' -- without the 'SecretKey' associated with 'pubKey'. encrypt :: - Monad m => RandomGen r => SubGroup q => - PublicKey q -> E q -> - S.StateT r m (EncryptionNonce q, Encryption q) + Reifies c FFC => + Monad m => RandomGen r => + PublicKey c -> E c -> + S.StateT r m (EncryptionNonce c, Encryption c) encrypt pubKey clear = do encNonce <- random -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'. @@ -91,8 +102,8 @@ -- | Non-Interactive Zero-Knowledge 'Proof' -- of knowledge of a discrete logarithm: -- @(secret == logBase base (base^secret))@. -data Proof q = Proof - { proof_challenge :: Challenge q +data Proof c = Proof + { proof_challenge :: Challenge c -- ^ 'Challenge' sent by the verifier to the prover -- to ensure that the prover really has knowledge -- of the secret and is not replaying. @@ -100,7 +111,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 q + , proof_response :: E c -- ^ A discrete logarithm sent by the prover to the verifier, -- as a response to 'proof_challenge'. -- @@ -122,6 +133,8 @@ -- to ensure that each 'prove' does not reveal any information -- about its secret. } deriving (Eq,Show,Generic,NFData) +deriving instance Reifies c FFC => ToJSON (Proof c) +deriving instance Reifies c FFC => FromJSON (Proof c) -- ** Type 'ZKP' -- | Zero-knowledge proof. @@ -149,13 +162,13 @@ -- 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 q = list (Commitment q) -> Challenge q +type Oracle list c = list (Commitment c) -> Challenge c --- | @('prove' sec commitBases oracle)@ +-- | @('prove' sec commitmentBases oracle)@ -- returns a 'Proof' that @sec@ is known -- (by proving the knowledge of its discrete logarithm). -- --- The 'Oracle' is given 'Commitment's equal to the 'commitBases' +-- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases' -- raised to the power of the secret nonce of the 'Proof', -- as those are the 'Commitment's that the verifier will obtain -- when composing the 'proof_challenge' and 'proof_response' together @@ -169,11 +182,12 @@ -- because two 'Proof's using the same 'Commitment' -- can be used to deduce @sec@ (using the special-soundness). prove :: - Monad m => RandomGen r => SubGroup q => Functor list => - E q -> list (G q) -> Oracle list q -> S.StateT r m (Proof q) -prove sec commitBases oracle = do + Reifies c FFC => + Monad m => RandomGen r => Functor list => + E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c) +prove sec commitmentBases oracle = do nonce <- random - let commitments = (^ nonce) <$> commitBases + let commitments = (^ nonce) <$> commitmentBases let proof_challenge = oracle commitments return Proof { proof_challenge @@ -188,7 +202,10 @@ -- -- Used in 'proveEncryption' to fill the returned 'DisjProof' -- with fake 'Proof's for all 'Disjunction's but the encrypted one. -fakeProof :: Monad m => RandomGen r => SubGroup q => S.StateT r m (Proof q) +fakeProof :: + Reifies c FFC => + Monad m => + RandomGen r => S.StateT r m (Proof c) fakeProof = do proof_challenge <- random proof_response <- random @@ -202,7 +219,7 @@ -- | @('commit' proof base basePowSec)@ returns a 'Commitment' -- from the given 'Proof' with the knowledge of the verifier. -commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q +commit :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c commit Proof{..} base basePowSec = base^proof_response * basePowSec^proof_challenge @@ -218,12 +235,12 @@ -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, type Disjunction = G -booleanDisjunctions :: SubGroup q => [Disjunction q] +booleanDisjunctions :: Reifies c FFC => [Disjunction c] booleanDisjunctions = List.take 2 groupGenInverses -intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q] +intervalDisjunctions :: Reifies c FFC => Natural -> Natural -> [Disjunction c] intervalDisjunctions mini maxi = - List.genericTake (fromMaybe 0 $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ + List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ List.genericDrop (nat mini) $ groupGenInverses @@ -236,9 +253,11 @@ -- | 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 q = DisjProof [Proof q] +newtype DisjProof c = DisjProof [Proof 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) -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ -- returns a 'DisjProof' that 'enc' 'encrypt's @@ -251,11 +270,12 @@ -- -- DOC: Pierrick Gaudry. , 2017. proveEncryption :: - Monad m => RandomGen r => SubGroup q => - PublicKey q -> ZKP -> - ([Disjunction q],[Disjunction q]) -> - (EncryptionNonce q, Encryption q) -> - S.StateT r m (DisjProof q) + Reifies c FFC => + Monad m => RandomGen r => + PublicKey c -> ZKP -> + ([Disjunction c],[Disjunction c]) -> + (EncryptionNonce c, Encryption c) -> + S.StateT r m (DisjProof 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 @@ -279,9 +299,9 @@ return (DisjProof proofs) verifyEncryption :: - Monad m => SubGroup q => - PublicKey q -> ZKP -> - [Disjunction q] -> (Encryption q, DisjProof q) -> + Reifies c FFC => Monad m => + PublicKey c -> ZKP -> + [Disjunction c] -> (Encryption c, DisjProof c) -> ExceptT ErrorVerifyEncryption m Bool verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of @@ -296,7 +316,7 @@ challengeSum = sum (proof_challenge <$> proofs) -- ** Hashing -encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString +encryptionStatement :: Reifies c FFC => ZKP -> Encryption c -> BS.ByteString encryptionStatement (ZKP voterZKP) Encryption{..} = "prove|"<>voterZKP<>"|" <> bytesNat encryption_nonce<>"," @@ -308,9 +328,9 @@ -- For the prover the 'Proof' comes from @fakeProof@, -- and for the verifier the 'Proof' comes from the prover. encryptionCommitments :: - SubGroup q => - PublicKey q -> Encryption q -> - Disjunction q -> Proof q -> [G q] + Reifies c FFC => + PublicKey c -> Encryption c -> + Disjunction c -> Proof c -> [G c] encryptionCommitments elecPubKey Encryption{..} disj proof = [ commit proof groupGen encryption_nonce -- == groupGen ^ nonce if 'Proof' comes from 'prove'. @@ -330,40 +350,40 @@ deriving (Eq,Show) -- * Type 'Question' -data Question q = Question - { question_text :: Text - , question_choices :: [Text] - , question_mini :: Opinion q - , question_maxi :: Opinion q +data Question = Question + { question_text :: !Text + , question_choices :: ![Text] + , question_mini :: !Natural + , question_maxi :: !Natural -- , question_blank :: Maybe Bool - } deriving (Eq,Show,Generic,NFData) + } deriving (Eq,Show,Generic,NFData,ToJSON,FromJSON) -- * Type 'Answer' -data Answer q = Answer - { answer_opinions :: [(Encryption q, DisjProof q)] +data Answer c = Answer + { answer_opinions :: ![(Encryption c, DisjProof c)] -- ^ Encrypted 'Opinion' for each 'question_choices' -- with a 'DisjProof' that they belong to [0,1]. - , answer_sumProof :: DisjProof q + , answer_sumProof :: !(DisjProof 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) +deriving instance Reifies c FFC => ToJSON (Answer c) +deriving instance Reifies c FFC => FromJSON (Answer c) -- | @('encryptAnswer' elecPubKey zkp quest opinions)@ -- returns an 'Answer' validable by 'verifyAnswer', -- unless an 'ErrorAnswer' is returned. encryptAnswer :: - Monad m => RandomGen r => SubGroup q => - PublicKey q -> ZKP -> - Question q -> [Bool] -> - S.StateT r (ExceptT ErrorAnswer m) (Answer q) + Reifies c FFC => + Monad m => RandomGen r => + PublicKey c -> ZKP -> + Question -> [Bool] -> + S.StateT r (ExceptT ErrorAnswer m) (Answer c) encryptAnswer elecPubKey zkp Question{..} opinionByChoice | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) = lift $ throwE $ - ErrorAnswer_WrongSumOfOpinions - (nat opinionsSum) - (nat question_mini) - (nat question_maxi) + ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi | List.length opinions /= List.length question_choices = lift $ throwE $ ErrorAnswer_WrongNumberOfOpinions @@ -374,12 +394,12 @@ individualProofs <- zipWithM (\opinion -> proveEncryption elecPubKey zkp $ if opinion - then ([booleanDisjunctions List.!!0],[]) - else ([],[booleanDisjunctions List.!!1])) + then (List.init booleanDisjunctions,[]) + else ([],List.tail booleanDisjunctions)) opinionByChoice encryptions sumProof <- proveEncryption elecPubKey zkp (List.tail <$> List.genericSplitAt - (nat (opinionsSum - question_mini)) + (fromJust $ opinionsSum`minusNaturalMaybe`question_mini) (intervalDisjunctions question_mini question_maxi)) ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's @@ -391,13 +411,13 @@ , answer_sumProof = sumProof } where - opinionsSum = sum opinions + opinionsSum = sum $ nat <$> opinions opinions = (\o -> if o then one else zero) <$> opinionByChoice verifyAnswer :: - SubGroup q => - PublicKey q -> ZKP -> - Question q -> Answer q -> Bool + Reifies c FFC => + PublicKey c -> ZKP -> + Question -> Answer c -> Bool verifyAnswer elecPubKey zkp Question{..} Answer{..} | List.length question_choices /= List.length answer_opinions = False | otherwise = either (const False) id $ runExcept $ do @@ -422,36 +442,110 @@ deriving (Eq,Show,Generic,NFData) -- * Type 'Election' -data Election q = Election - { election_name :: Text - , election_description :: Text - , election_PublicKey :: PublicKey q - , election_questions :: [Question q] - , election_uuid :: UUID - , election_hash :: Hash -- TODO: serialize to JSON to calculate this +data Election c = Election + { election_name :: !Text + , election_description :: !Text + , election_crypto :: !(ElectionCrypto c) + , election_questions :: ![Question] + , election_uuid :: !UUID + , election_hash :: !Hash } deriving (Eq,Show,Generic,NFData) +instance ToJSON (Election c) where + toJSON Election{..} = + JSON.object + [ "name" .= election_name + , "description" .= election_description + , "public_key" .= election_crypto + , "questions" .= election_questions + , "uuid" .= election_uuid + ] + toEncoding Election{..} = + JSON.pairs + ( "name" .= election_name + <> "description" .= election_description + <> "public_key" .= election_crypto + <> "questions" .= election_questions + <> "uuid" .= election_uuid + ) +instance FromJSON (Election c) where + parseJSON = JSON.withObject "Election" $ \o -> Election + <$> o .: "name" + <*> o .: "description" + <*> o .: "public_key" + <*> o .: "questions" + <*> o .: "uuid" + <*> pure (hashJSON (JSON.Object o)) + +-- ** 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)), ..} + + +instance ToJSON (ElectionCrypto c) where + toJSON (ElectionCrypto_FFC ffc pubKey) = + JSON.object + [ "group" .= ffc + , "y" .= nat pubKey + ] + toEncoding (ElectionCrypto_FFC ffc pubKey) = + JSON.pairs + ( "group" .= ffc + <> "y" .= nat pubKey + ) +instance FromJSON (ElectionCrypto c) where + parseJSON = JSON.withObject "ElectionCrypto" $ \o -> do + ffc <- o .: "group" + pubKey <- reify ffc $ \(_::Proxy s) -> nat <$> ((.:) @(PublicKey s) o "y") + {- + unless (nat ffc_groupGen < ffc_fieldCharac) $ + JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o) + -} + return $ ElectionCrypto_FFC ffc (G (F pubKey)) + + -- ** Type 'Hash' newtype Hash = Hash Text deriving (Eq,Ord,Show,Generic) + deriving anyclass (ToJSON,FromJSON) deriving newtype NFData +hashJSON :: ToJSON a => a -> Hash +hashJSON = Hash . TL.toStrict . TL.decodeUtf8 . BSL64.encode . JSON.encode + +hashElection :: Election c -> Election c +hashElection elec = elec{election_hash=hashJSON elec} + -- * Type 'Ballot' -data Ballot q = Ballot - { ballot_answers :: [Answer q] - , ballot_signature :: Maybe (Signature q) - , ballot_election_uuid :: UUID - , ballot_election_hash :: Hash +data Ballot c = Ballot + { ballot_answers :: ![Answer c] + , ballot_signature :: !(Maybe (Signature c)) + , ballot_election_uuid :: !UUID + , ballot_election_hash :: !Hash } deriving (Generic,NFData) +deriving instance Reifies c FFC => ToJSON (Ballot c) +deriving instance Reifies c FFC => FromJSON (Ballot c) -- | @('encryptBallot' elec ('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 :: - Monad m => RandomGen r => SubGroup q => - Election q -> Maybe (SecretKey q) -> [[Bool]] -> - S.StateT r (ExceptT ErrorBallot m) (Ballot q) + Reifies c FFC => + Monad m => RandomGen r => + Election c -> + Maybe (SecretKey c) -> [[Bool]] -> + S.StateT r (ExceptT ErrorBallot m) (Ballot c) encryptBallot Election{..} ballotSecKeyMay opinionsByQuest | List.length election_questions /= List.length opinionsByQuest = lift $ throwE $ @@ -468,7 +562,7 @@ where ballotPubKey = publicKey ballotSecKey ballot_answers <- S.mapStateT (withExceptT ErrorBallot_Answer) $ - zipWithM (encryptAnswer election_PublicKey voterZKP) + zipWithM (encryptAnswer (electionCrypto_FFC_PublicKey election_crypto) voterZKP) election_questions opinionsByQuest ballot_signature <- case voterKeys of Nothing -> return Nothing @@ -490,8 +584,9 @@ , ballot_signature } -verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool +verifyBallot :: Reifies c FFC => Election c -> Ballot 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 && @@ -506,7 +601,7 @@ (signatureStatement ballot_answers) in and $ isValidSign : - List.zipWith (verifyAnswer election_PublicKey zkpSign) + List.zipWith (verifyAnswer elecPubKey zkpSign) election_questions ballot_answers -- ** Type 'Signature' @@ -515,25 +610,27 @@ -- Used by each voter to sign his/her encrypted 'Ballot' -- using his/her 'Credential', -- in order to avoid ballot stuffing. -data Signature q = Signature - { signature_publicKey :: PublicKey q +data Signature c = Signature + { signature_publicKey :: !(PublicKey c) -- ^ Verification key. - , signature_proof :: Proof q + , signature_proof :: !(Proof c) } deriving (Generic,NFData) +deriving instance Reifies c FFC => ToJSON (Signature c) +deriving instance Reifies c FFC => FromJSON (Signature c) -- *** Hashing -- | @('signatureStatement' answers)@ -- returns the encrypted material to be signed: -- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@. -signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q] +signatureStatement :: Reifies c FFC => Foldable f => f (Answer c) -> [G c] signatureStatement = foldMap $ \Answer{..} -> (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) -> [encryption_nonce, encryption_vault] -- | @('signatureCommitments' voterZKP commitment)@ -signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString +signatureCommitments :: ZKP -> Commitment c -> BS.ByteString signatureCommitments (ZKP voterZKP) commitment = "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement <> bytesNat commitment<>"|" diff --git a/src/Voting/Protocol/FFC.hs b/src/Voting/Protocol/FFC.hs new file mode 100644 --- /dev/null +++ b/src/Voting/Protocol/FFC.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 + +import Control.Arrow (first) +import Control.Applicative (Applicative(..)) +import Control.DeepSeq (NFData) +import Control.Monad (Monad(..), unless) +import Control.Monad.Trans.Reader (ReaderT(..), asks) +import Control.Monad.Trans.Class (MonadTrans(..)) +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(..), fromMaybe, fromJust) +import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..), reify) +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.Char as Char +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Prelude as Num +import qualified System.Random as Random + +-- * Type 'FFC' +-- | Mutiplicative Sub-Group of a Finite Prime Field. +-- +-- NOTE: an 'FFC' term-value is brought into the context of many functions +-- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect' +-- that 'FFC' at the term-level (a surprising technique but a very useful one). +-- Doing like this is simpler than working in a 'Monad' (like a 'Reader'), +-- and enables that 'FFC' term to be used simply in instances' methods +-- not supporting an inner 'Monad', like 'parseJSON', 'randomR', 'fromEnum' or 'arbitrary'. +-- Aside from that, the sharing of 'FFC' amongst several types +-- is encoded at the type-level by including @c@ +-- as a phantom type of 'F', 'G' and 'E'. +data FFC = FFC + { ffc_name :: Text + , ffc_fieldCharac :: !Natural + -- ^ The prime number characteristic of a Finite Prime Field. + -- + -- ElGamal's hardness to decrypt requires a large prime number + -- to form the 'Multiplicative' subgroup. + , ffc_groupGen :: !Natural + -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field. + -- + -- NOTE: since 'ffc_fieldCharac' is prime, + -- the 'Multiplicative' subgroup is cyclic, + -- and there are phi('fieldCharac'-1) many choices for the generator of the group, + -- where phi is the Euler totient function. + , ffc_groupOrder :: !Natural + -- ^ The order of the subgroup. + -- + -- WARNING: 'ffc_groupOrder' MUST be a prime number dividing @('ffc_fieldCharac'-1)@ + -- to ensure that ElGamal is secure in terms of the DDH assumption. + } deriving (Eq,Show,Generic,NFData) +deriving instance ToJSON FFC +instance FromJSON FFC where + parseJSON = JSON.withObject "FFC" $ \o -> do + ffc_name <- fromMaybe "" <$> (o .:? "name") + ffc_fieldCharac <- o .: "p" + ffc_groupGen <- o .: "g" + ffc_groupOrder <- o .: "q" + -- TODO: check p is probable prime + -- TODO: check q is probable prime + unless (nat ffc_groupGen < ffc_fieldCharac) $ + JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o) + unless (ffc_groupOrder < ffc_fieldCharac) $ + JSON.typeMismatch "FFC: groupOrder is not lower than fieldCharac" (JSON.Object o) + unless (nat ffc_groupGen > 1) $ + JSON.typeMismatch "FFC: groupGen is not greater than 1" (JSON.Object o) + unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $ + JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o) + return FFC{..} + +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)) + +-- ** Examples +-- | Weak parameters for debugging purposes only. +weakFFC :: FFC +weakFFC = FFC + { ffc_name = "weakFFC" + , ffc_fieldCharac = 263 + , ffc_groupGen = 2 + , ffc_groupOrder = 131 + } + +-- | Parameters used in Belenios. +-- A 2048-bit 'fieldCharac' of a Finite Prime Field, +-- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup +-- generated by 'groupGen'. +beleniosFFC :: FFC +beleniosFFC = FFC + { ffc_name = "beleniosFFC" + , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719 + , ffc_groupGen = 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627 + , ffc_groupOrder = 78571733251071885079927659812671450121821421258408794611510081919805623223441 + } + +-- * Type 'F' +-- | The type of the elements of a Finite Prime Field. +-- +-- A field must satisfy the following properties: +-- +-- * @(f, ('+'), 'zero')@ forms an abelian group, +-- called the 'Additive' group of 'f'. +-- +-- * @('NonNull' f, ('*'), 'one')@ forms an abelian group, +-- called the 'Multiplicative' group of 'f'. +-- +-- * ('*') is associative: +-- @(a'*'b)'*'c == a'*'(b'*'c)@ and +-- @a'*'(b'*'c) == (a'*'b)'*'c@. +-- +-- * ('*') and ('+') are both commutative: +-- @a'*'b == b'*'a@ and +-- @a'+'b == b'+'a@ +-- +-- * ('*') and ('+') are both left and right distributive: +-- @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and +-- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@ +-- +-- The 'Natural' is always within @[0..'fieldCharac'-1]@. +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) +instance Reifies c FFC => FromJSON (F 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 + = return (F x) + parseJSON json = JSON.typeMismatch "F" json +instance Reifies c FFC => FromNatural (F c) where + fromNatural i = F $ abs $ i `mod` fieldCharac @c + where + abs x | x < 0 = x + fieldCharac @c + | otherwise = x +instance ToNatural (F c) where + nat = unF +instance Reifies c FFC => Additive (F c) where + zero = F 0 + F x + F y = F $ (x + y) `mod` fieldCharac @c +instance Reifies c FFC => Negable (F c) where + neg (F x) + | x == 0 = zero + | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x +instance Reifies c FFC => Multiplicative (F c) where + one = F 1 + F x * F y = F $ (x * y) `mod` fieldCharac @c +instance Reifies c FFC => Random.Random (F c) where + randomR (F lo, F hi) = + first (F . fromIntegral) . + Random.randomR + ( 0`max`toInteger lo + , toInteger hi`min`(toInteger (fieldCharac @c) - 1) ) + random = + 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 "G" 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) + +-- | @('hash' bs gs)@ returns as a number in 'E' +-- the SHA256 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 = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) + fromNatural (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h) + +-- * 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 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 "E" 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 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 @@ -1,18 +1,19 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Tally where import Control.DeepSeq (NFData) import Control.Monad (Monad(..), mapM, unless) import Control.Monad.Trans.Except (Except, ExceptT, throwE) +import Data.Aeson (ToJSON(..),FromJSON(..)) import Data.Eq (Eq(..)) import Data.Function (($)) import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..)) -import Data.Text (Text) -import Data.Tuple (fst, uncurry) +import Data.Tuple (fst) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Prelude (fromIntegral) @@ -23,103 +24,97 @@ import qualified Data.Map.Strict as Map import Voting.Protocol.Utils -import Voting.Protocol.Arithmetic +import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election -- * Type 'Tally' -data Tally q = Tally - { tally_countMax :: Natural +data Tally 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. -- -- 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 q + , tally_encByChoiceByQuest :: !(EncryptedTally c) -- ^ 'Encryption' by 'Question' by 'Ballot'. - , tally_decShareByTrustee :: [DecryptionShare q] + , tally_decShareByTrustee :: ![DecryptionShare c] -- ^ 'DecryptionShare' by trustee. - , tally_countByChoiceByQuest :: [[Natural]] + , tally_countByChoiceByQuest :: ![[Natural]] -- ^ The decrypted count of supportive 'Opinion's, by choice by 'Question'. } deriving (Eq,Show,Generic,NFData) +deriving instance Reifies c FFC => ToJSON (Tally c) +deriving instance Reifies c FFC => FromJSON (Tally c) -- ** Type 'EncryptedTally' --- | 'Encryption' by 'Choice' by 'Question'. -type EncryptedTally q = [[Encryption q]] +-- | 'Encryption' by choice by 'Question'. +type EncryptedTally c = [[Encryption c]] -- | @('encryptedTally' ballots)@ -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's. -encryptedTally :: SubGroup q => [Ballot q] -> (EncryptedTally q, Natural) +encryptedTally :: Reifies c FFC => [Ballot c] -> (EncryptedTally c, Natural) encryptedTally ballots = ( List.foldr (\Ballot{..} -> List.zipWith (\Answer{..} -> List.zipWith (+) (fst <$> answer_opinions)) - ballot_answers - ) + ballot_answers) (List.repeat (List.repeat zero)) ballots , fromIntegral $ List.length ballots ) -- ** Type 'DecryptionShareCombinator' -type DecryptionShareCombinator q = - [DecryptionShare q] -> Except ErrorDecryptionShare [[DecryptionFactor q]] +type DecryptionShareCombinator c = + EncryptedTally c -> [DecryptionShare c] -> Except ErrorTally [[DecryptionFactor c]] proveTally :: - SubGroup q => - (EncryptedTally q, Natural) -> [DecryptionShare q] -> - DecryptionShareCombinator q -> - Except ErrorDecryptionShare (Tally q) + Reifies c FFC => + (EncryptedTally c, Natural) -> [DecryptionShare c] -> + DecryptionShareCombinator c -> + Except ErrorTally (Tally c) proveTally (tally_encByChoiceByQuest, tally_countMax) tally_decShareByTrustee decShareCombinator = do - decFactorByChoiceByQuest <- decShareCombinator tally_decShareByTrustee - dec <- isoZipWithM err - (\encByChoice decFactorByChoice -> - maybe err return $ - isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor) - encByChoice - decFactorByChoice) + decFactorByChoiceByQuest <- + decShareCombinator + tally_encByChoiceByQuest + tally_decShareByTrustee + dec <- isoZipWithM (throwE ErrorTally_NumberOfQuestions) + (maybe (throwE ErrorTally_NumberOfChoices) return `o2` + isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor)) tally_encByChoiceByQuest decFactorByChoiceByQuest let logMap = Map.fromList $ List.zip groupGenPowers [0..tally_countMax] let log x = - maybe (throwE $ ErrorDecryptionShare_InvalidMaxCount) return $ + maybe (throwE ErrorTally_CannotDecryptCount) return $ Map.lookup x logMap tally_countByChoiceByQuest <- (log `mapM`)`mapM`dec return Tally{..} - where err = throwE $ ErrorDecryptionShare_Invalid "proveTally" verifyTally :: - SubGroup q => - Tally q -> DecryptionShareCombinator q -> - Except ErrorDecryptionShare () + Reifies c FFC => + Tally c -> DecryptionShareCombinator c -> + Except ErrorTally () verifyTally Tally{..} decShareCombinator = do - decFactorByChoiceByQuest <- decShareCombinator tally_decShareByTrustee - isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyTally") - (isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyTally") + decFactorByChoiceByQuest <- decShareCombinator tally_encByChoiceByQuest tally_decShareByTrustee + isoZipWith3M_ (throwE ErrorTally_NumberOfQuestions) + (isoZipWith3M_ (throwE ErrorTally_NumberOfChoices) (\Encryption{..} decFactor count -> do let groupGenPowCount = encryption_vault / decFactor unless (groupGenPowCount == groupGen ^ fromNatural count) $ - throwE ErrorDecryptionShare_Wrong)) + throwE ErrorTally_WrongProof)) tally_encByChoiceByQuest decFactorByChoiceByQuest tally_countByChoiceByQuest -- ** Type 'DecryptionShare' --- | A decryption share. It is computed by a trustee --- from its 'SecretKey' share and the 'EncryptedTally', --- and contains a cryptographic 'Proof' that it hasn't cheated. -data DecryptionShare q = DecryptionShare - { decryptionShare_factors :: [[DecryptionFactor q]] - -- ^ 'DecryptionFactor' by choice by 'Question'. - , decryptionShare_proofs :: [[Proof q]] - -- ^ 'Proof's that 'decryptionShare_factors' were correctly computed. - } deriving (Eq,Show,Generic,NFData) +-- | A decryption share is a 'DecryptionFactor' and a decryption 'Proof', by choice by 'Question'. +-- Computed by a trustee in 'proveDecryptionShare'. +type DecryptionShare c = [[(DecryptionFactor c, Proof c)]] -- *** Type 'DecryptionFactor' -- | @'encryption_nonce' '^'trusteeSecKey@ @@ -127,33 +122,37 @@ -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare :: - Monad m => SubGroup q => RandomGen r => - EncryptedTally q -> SecretKey q -> S.StateT r m (DecryptionShare q) -proveDecryptionShare encByChoiceByQuest trusteeSecKey = do - res <- (proveDecryptionFactor trusteeSecKey `mapM`) `mapM` encByChoiceByQuest - return $ uncurry DecryptionShare $ List.unzip (List.unzip <$> res) + Monad m => Reifies c FFC => RandomGen r => + EncryptedTally c -> SecretKey c -> S.StateT r m (DecryptionShare c) +proveDecryptionShare encByChoiceByQuest trusteeSecKey = + (proveDecryptionFactor trusteeSecKey `mapM`) `mapM` encByChoiceByQuest proveDecryptionFactor :: - Monad m => SubGroup q => RandomGen r => - SecretKey q -> Encryption q -> S.StateT r m (DecryptionFactor q, Proof q) + Monad m => Reifies c FFC => RandomGen r => + SecretKey c -> Encryption c -> S.StateT r m (DecryptionFactor c, Proof c) proveDecryptionFactor trusteeSecKey Encryption{..} = do proof <- prove trusteeSecKey [groupGen, encryption_nonce] (hash zkp) return (encryption_nonce^trusteeSecKey, proof) where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: SubGroup q => PublicKey q -> BS.ByteString +decryptionShareStatement :: Reifies c FFC => PublicKey c -> BS.ByteString decryptionShareStatement pubKey = "decrypt|"<>bytesNat pubKey<>"|" --- *** Type 'ErrorDecryptionShare' -data ErrorDecryptionShare - = ErrorDecryptionShare_Invalid Text - -- ^ The number of 'DecryptionFactor's or - -- the number of 'Proof's is not the same - -- or not the expected number. - | ErrorDecryptionShare_Wrong +-- *** Type 'ErrorTally' +data ErrorTally + = ErrorTally_NumberOfQuestions + -- ^ The number of 'Question's is not the one expected. + | ErrorTally_NumberOfChoices + -- ^ The number of choices is not the one expected. + | ErrorTally_NumberOfTrustees + -- ^ The number of trustees is not the one expected. + | ErrorTally_WrongProof -- ^ The 'Proof' of a 'DecryptionFactor' is wrong. - | ErrorDecryptionShare_InvalidMaxCount + | ErrorTally_CannotDecryptCount + -- ^ Raised by 'proveTally' when the discrete logarithm of @'groupGen' '^'count@ + -- cannot be computed, likely because 'tally_countMax' is wrong, + -- or because the 'EncryptedTally' or 'DecryptionShare's have not been verified. deriving (Eq,Show,Generic,NFData) -- | @('verifyDecryptionShare' encTally trusteePubKey trusteeDecShare)@ @@ -161,27 +160,24 @@ -- (supposedly submitted by a trustee whose 'PublicKey' is 'trusteePubKey') -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare :: - Monad m => SubGroup q => - EncryptedTally q -> PublicKey q -> DecryptionShare q -> - ExceptT ErrorDecryptionShare m () -verifyDecryptionShare encTally trusteePubKey DecryptionShare{..} = + Monad m => Reifies c FFC => + EncryptedTally c -> PublicKey c -> DecryptionShare c -> + ExceptT ErrorTally m () +verifyDecryptionShare encByChoiceByQuest trusteePubKey = let zkp = decryptionShareStatement trusteePubKey in - isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyDecryptionShare") - (isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyDecryptionShare") $ - \Encryption{..} decFactor proof -> + isoZipWithM_ (throwE ErrorTally_NumberOfQuestions) + (isoZipWithM_ (throwE ErrorTally_NumberOfChoices) $ + \Encryption{..} (decFactor, proof) -> unless (proof_challenge proof == hash zkp [ commit proof groupGen trusteePubKey , commit proof encryption_nonce decFactor - ]) $ - throwE ErrorDecryptionShare_Wrong) - encTally - decryptionShare_factors - decryptionShare_proofs + ]) $ throwE ErrorTally_WrongProof) + encByChoiceByQuest verifyDecryptionShareByTrustee :: - Monad m => SubGroup q => - EncryptedTally q -> [PublicKey q] -> [DecryptionShare q] -> - ExceptT ErrorDecryptionShare m () + Monad m => Reifies c FFC => + EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] -> + ExceptT ErrorTally m () verifyDecryptionShareByTrustee encTally = - isoZipWithM_ (throwE $ ErrorDecryptionShare_Invalid "verifyDecryptionShare") + isoZipWithM_ (throwE ErrorTally_NumberOfTrustees) (verifyDecryptionShare encTally) 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 @@ -1,27 +1,35 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Trustee.Indispensable where +import Control.DeepSeq (NFData) import Control.Monad (Monad(..), foldM, unless) import Control.Monad.Trans.Except (ExceptT(..), throwE) +import Data.Aeson (ToJSON(..),FromJSON(..)) import Data.Eq (Eq(..)) import Data.Function (($)) +import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..)) +import Data.Tuple (fst) +import GHC.Generics (Generic) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.ByteString as BS import qualified Data.List as List import Voting.Protocol.Utils -import Voting.Protocol.Arithmetic +import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally -- * Type 'TrusteePublicKey' -data TrusteePublicKey q = TrusteePublicKey - { trustee_PublicKey :: PublicKey q - , trustee_SecretKeyProof :: Proof q +data TrusteePublicKey c = TrusteePublicKey + { trustee_PublicKey :: !(PublicKey c) + , trustee_SecretKeyProof :: !(Proof c) -- ^ NOTE: It is important to ensure -- that each trustee generates its key pair independently -- of the 'PublicKey's published by the other trustees. @@ -35,11 +43,13 @@ -- must 'prove' knowledge of the corresponding 'SecretKey'. -- Which is done in 'proveIndispensableTrusteePublicKey' -- and 'verifyIndispensableTrusteePublicKey'. - } deriving (Eq,Show) + } deriving (Eq,Show,Generic,NFData) +deriving instance Reifies c FFC => ToJSON (TrusteePublicKey c) +deriving instance Reifies c FFC => FromJSON (TrusteePublicKey c) -- ** Type 'ErrorTrusteePublicKey' data ErrorTrusteePublicKey - = ErrorTrusteePublicKey_Wrong + = ErrorTrusteePublicKey_WrongProof -- ^ The 'trustee_SecretKeyProof' is wrong. deriving (Eq,Show) @@ -47,8 +57,8 @@ -- returns the 'PublicKey' associated to 'trustSecKey' -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey :: - Monad m => RandomGen r => SubGroup q => - SecretKey q -> S.StateT r m (TrusteePublicKey q) + Reifies c FFC => Monad m => RandomGen r => + SecretKey c -> S.StateT r m (TrusteePublicKey c) proveIndispensableTrusteePublicKey trustSecKey = do let trustee_PublicKey = publicKey trustSecKey trustee_SecretKeyProof <- @@ -61,46 +71,52 @@ -- does 'prove' that the 'SecretKey' associated with -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey :: - Monad m => SubGroup q => - TrusteePublicKey q -> + Reifies c FFC => Monad m => + TrusteePublicKey c -> ExceptT ErrorTrusteePublicKey m () verifyIndispensableTrusteePublicKey TrusteePublicKey{..} = unless ((proof_challenge trustee_SecretKeyProof ==) $ hash (indispensableTrusteePublicKeyStatement trustee_PublicKey) [commit trustee_SecretKeyProof groupGen trustee_PublicKey]) $ - throwE ErrorTrusteePublicKey_Wrong + throwE ErrorTrusteePublicKey_WrongProof -- ** Hashing -indispensableTrusteePublicKeyStatement :: PublicKey q -> BS.ByteString -indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|" +indispensableTrusteePublicKeyStatement :: PublicKey c -> BS.ByteString +indispensableTrusteePublicKeyStatement trustPubKey = + "pok|"<>bytesNat trustPubKey<>"|" -- * 'Election''s 'PublicKey' combineIndispensableTrusteePublicKeys :: - SubGroup q => [TrusteePublicKey q] -> PublicKey q + Reifies c FFC => [TrusteePublicKey c] -> PublicKey c combineIndispensableTrusteePublicKeys = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one verifyIndispensableDecryptionShareByTrustee :: - SubGroup q => Monad m => - EncryptedTally q -> [PublicKey q] -> [DecryptionShare q] -> - ExceptT ErrorDecryptionShare m () -verifyIndispensableDecryptionShareByTrustee encTally = - isoZipWithM_ (throwE $ ErrorDecryptionShare_Invalid "verifyIndispensableDecryptionShareByTrustee") - (verifyDecryptionShare encTally) + Reifies c FFC => Monad m => + EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] -> + ExceptT ErrorTally m () +verifyIndispensableDecryptionShareByTrustee encByChoiceByQuest = + isoZipWithM_ (throwE $ ErrorTally_NumberOfTrustees) + (verifyDecryptionShare encByChoiceByQuest) -- | @('combineDecryptionShares' pubKeyByTrustee decShareByTrustee)@ -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares :: - SubGroup q => [PublicKey q] -> EncryptedTally q -> DecryptionShareCombinator q -combineIndispensableDecryptionShares pubKeyByTrustee encTally decShareByTrustee = do - verifyIndispensableDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee - (d0,ds) <- maybe err return $ List.uncons decShareByTrustee - foldM - (\decFactorByChoiceByQuest DecryptionShare{..} -> - isoZipWithM err - (\acc df -> maybe err return $ isoZipWith (*) acc df) - decFactorByChoiceByQuest decryptionShare_factors) - (decryptionShare_factors d0) ds - where err = throwE $ ErrorDecryptionShare_Invalid "combineIndispensableDecryptionShares" + Reifies c FFC => [PublicKey c] -> DecryptionShareCombinator c +combineIndispensableDecryptionShares + pubKeyByTrustee + encByChoiceByQuest + decByChoiceByQuestByTrustee = do + verifyIndispensableDecryptionShareByTrustee + encByChoiceByQuest + pubKeyByTrustee + decByChoiceByQuestByTrustee + (dec0,decs) <- + maybe (throwE ErrorTally_NumberOfTrustees) return $ + List.uncons decByChoiceByQuestByTrustee + foldM (isoZipWithM (throwE ErrorTally_NumberOfQuestions) + (maybe (throwE ErrorTally_NumberOfChoices) return `o2` + isoZipWith (\a (decFactor, _proof) -> a * decFactor))) + ((fst <$>) <$> dec0) decs 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 @@ -10,6 +10,12 @@ import Data.Traversable (Traversable(..)) import qualified Data.List as List +-- | Like ('.') but with two arguments. +o2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d +o2 f g = \x y -> f (g x y) +infixr 9 `o2` +{-# INLINE o2 #-} + -- | NOTE: check the lengths before applying @f@. isoZipWith :: (a->b->c) -> [a]->[b]->Maybe [c] isoZipWith f as bs @@ -25,38 +31,29 @@ where al = List.length as isoZipWithM :: - Applicative m => - m () -> - (a -> b -> m c) -> - [a] -> [b] -> m [c] + Applicative f => + f () -> (a->b->f c) -> [a]->[b]->f [c] isoZipWithM err f as bs = maybe ([] <$ err) sequenceA $ isoZipWith f as bs isoZipWithM_ :: - Applicative m => - m () -> - (a -> b -> m c) -> - [a] -> [b] -> m () + Applicative f => + f () -> (a->b->f c) -> [a]->[b]->f () isoZipWithM_ err f as bs = maybe err sequenceA_ $ isoZipWith f as bs isoZipWith3M :: - Applicative m => - m () -> - (a -> b -> c -> m d) -> - [a] -> [b] -> [c] -> m [d] + Applicative f => + f () -> (a->b->c->f d) -> [a]->[b]->[c]->f [d] isoZipWith3M err f as bs cs = maybe ([] <$ err) sequenceA $ isoZipWith3 f as bs cs isoZipWith3M_ :: - Applicative m => - m () -> - (a -> b -> c -> m d) -> - [a] -> [b] -> [c] -> - m () + Applicative f => + f () -> (a->b->c->f d) -> [a]->[b]->[c]->f () isoZipWith3M_ err f as bs cs = maybe err sequenceA_ $ isoZipWith3 f as bs cs diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.26 +resolver: lts-13.19 packages: - '.' - location: '../hjugement' diff --git a/tests/HUnit.hs b/tests/HUnit.hs --- a/tests/HUnit.hs +++ b/tests/HUnit.hs @@ -1,6 +1,6 @@ module HUnit where import Test.Tasty -import qualified HUnit.Arithmetic +import qualified HUnit.FFC import qualified HUnit.Credential import qualified HUnit.Election import qualified HUnit.Trustee @@ -8,7 +8,7 @@ hunits :: TestTree hunits = testGroup "HUnit" - [ HUnit.Arithmetic.hunit + [ HUnit.FFC.hunit , HUnit.Credential.hunit , HUnit.Election.hunit , HUnit.Trustee.hunit diff --git a/tests/HUnit/Arithmetic.hs b/tests/HUnit/Arithmetic.hs deleted file mode 100644 --- a/tests/HUnit/Arithmetic.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE OverloadedStrings #-} -module HUnit.Arithmetic where - -import Test.Tasty.HUnit -import Voting.Protocol -import Utils - -hunit :: TestTree -hunit = testGroup "Arithmetic" - [ testGroup "inv" - [ testGroup "WeakParams" - [ testCase "groupGen" $ - inv (groupGen @WeakParams) @?= - groupGen ^ E (groupOrder @WeakParams + neg one) - ] - , testGroup "BeleniosParams" - [ testCase "groupGen" $ - inv (groupGen @BeleniosParams) @?= - groupGen ^ E (groupOrder @BeleniosParams + neg one) - ] - ] - , testGroup "hash" - [ testGroup "WeakParams" - [ testCase "[groupGen]" $ - hash "start" [groupGen @WeakParams] @?= - fromNatural 100 - , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @WeakParams, groupGen] @?= - fromNatural 16 - ] - , testGroup "BeleniosParams" - [ testCase "[groupGen]" $ - hash "start" [groupGen @BeleniosParams] @?= - fromNatural 1832875488615060263192702367259 - , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @BeleniosParams, groupGen] @?= - fromNatural 2495277906542783643199702546512 - ] - ] - ] diff --git a/tests/HUnit/Credential.hs b/tests/HUnit/Credential.hs --- a/tests/HUnit/Credential.hs +++ b/tests/HUnit/Credential.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedStrings #-} module HUnit.Credential where @@ -25,29 +24,30 @@ , testGroup "readCredential" $ let (==>) inp exp = testCase (show inp) $ readCredential inp @?= exp in - [ "" ==> Left CredentialError_Length - , "xLcs7ev6Jy6FH_E" ==> Left (CredentialError_BadChar '_') - , "xLcs7ev6Jy6FHIE" ==> Left (CredentialError_BadChar 'I') - , "xLcs7ev6Jy6FH0E" ==> Left (CredentialError_BadChar '0') - , "xLcs7ev6Jy6FHOE" ==> Left (CredentialError_BadChar 'O') - , "xLcs7ev6Jy6FHlE" ==> Left (CredentialError_BadChar 'l') - , "xLcs7ev6Jy6FH6" ==> Left CredentialError_Length - , "xLcs7ev6Jy6FHHy1" ==> Left CredentialError_Length - , "xLcs7ev6Jy6FHHF" ==> Left CredentialError_Checksum + [ "" ==> Left ErrorToken_Length + , "xLcs7ev6Jy6FH_E" ==> Left (ErrorToken_BadChar '_') + , "xLcs7ev6Jy6FHIE" ==> Left (ErrorToken_BadChar 'I') + , "xLcs7ev6Jy6FH0E" ==> Left (ErrorToken_BadChar '0') + , "xLcs7ev6Jy6FHOE" ==> Left (ErrorToken_BadChar 'O') + , "xLcs7ev6Jy6FHlE" ==> Left (ErrorToken_BadChar 'l') + , "xLcs7ev6Jy6FH6" ==> Left ErrorToken_Length + , "xLcs7ev6Jy6FHHy1" ==> Left ErrorToken_Length + , "xLcs7ev6Jy6FHHF" ==> Left ErrorToken_Checksum , "xLcs7ev6Jy6FHHE" ==> Right (Credential "xLcs7ev6Jy6FHHE") ] , testGroup "credentialSecretKey" $ - [ testSecretKey @WeakParams 0 $ E (F 122) - , testSecretKey @WeakParams 1 $ E (F 35) - , testSecretKey @BeleniosParams 0 $ E (F 2317630607062989137269685509390) - , testSecretKey @BeleniosParams 1 $ E (F 1968146140481358915910346867611) + [ testSecretKey weakFFC 0 122 + , testSecretKey weakFFC 1 35 + , testSecretKey beleniosFFC 0 2317630607062989137269685509390 + , testSecretKey beleniosFFC 1 1968146140481358915910346867611 ] ] -testSecretKey :: forall q. SubGroup q => Int -> E q -> TestTree -testSecretKey seed exp = +testSecretKey :: FFC -> Int -> Natural -> TestTree +testSecretKey ffc seed exp = + reify ffc $ \(Proxy::Proxy c) -> let (uuid@(UUID u), cred@(Credential c)) = (`S.evalState` Random.mkStdGen seed) $ (,) <$> randomUUID <*> randomCredential in testCase (show (u,c)) $ - credentialSecretKey @q uuid cred @?= 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 @@ -1,11 +1,12 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} 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 import Voting.Protocol @@ -16,54 +17,56 @@ hunit = testGroup "Election" [ testGroup "groupGenInverses" [ testCase "WeakParams" $ - List.take 10 (groupGenInverses @WeakParams) @?= - [groupGen^neg (fromNatural n) | n <- [0..9]] + reify weakFFC $ \(Proxy::Proxy c) -> + List.take 10 (groupGenInverses @c) @?= + [groupGen^neg (fromNatural n) | n <- [0..9]] , testCase "BeleniosParams" $ - List.take 10 (groupGenInverses @BeleniosParams) @?= - [groupGen^neg (fromNatural n) | n <- [0..9]] + reify beleniosFFC $ \(Proxy::Proxy c) -> + List.take 10 (groupGenInverses @c) @?= + [groupGen^neg (fromNatural n) | n <- [0..9]] ] , testGroup "encryptBallot" $ - [ testsEncryptBallot @WeakParams - , testsEncryptBallot @BeleniosParams + [ testsEncryptBallot weakFFC + , testsEncryptBallot beleniosFFC ] ] -testsEncryptBallot :: forall q. Params q => TestTree -testsEncryptBallot = - testGroup (paramsName @q) - [ testEncryptBallot @q 0 +testsEncryptBallot :: FFC -> TestTree +testsEncryptBallot ffc = + testGroup (Text.unpack $ ffc_name ffc) + [ testEncryptBallot ffc 0 [Question "q1" ["a1","a2","a3"] zero one] [[True, False, False]] (Right True) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" ["a1","a2","a3"] zero one] [[False, False, False]] (Right True) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" ["a1","a2","a3"] zero one] [[False, False, False]] (Right True) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" [] zero one] [] (Left (ErrorBallot_WrongNumberOfAnswers 0 1)) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" ["a1","a2"] one one] [[True]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2))) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" ["a1","a2","a3"] zero one] [[True, True, False]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1))) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" ["a1","a2","a3"] one one] [[False, False, False]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1))) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [Question "q1" ["a1","a2"] one one] [[False, False, True]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2))) - , testEncryptBallot @q 0 + , testEncryptBallot ffc 0 [ Question "q1" ["a11","a12","a13"] zero (one+one) , Question "q2" ["a21","a22","a23"] one one ] @@ -73,25 +76,25 @@ ] testEncryptBallot :: - forall q. SubGroup q => - Int -> [Question q] -> [[Bool]] -> + FFC -> Int -> [Question] -> [[Bool]] -> Either ErrorBallot Bool -> TestTree -testEncryptBallot seed quests opins exp = +testEncryptBallot ffc seed quests opins exp = let got = + reify ffc $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do uuid <- randomUUID cred <- randomCredential - let ballotSecKey = credentialSecretKey @q uuid cred + let ballotSecKey = credentialSecretKey @c uuid cred elecPubKey <- publicKey <$> randomSecretKey let elec = Election { election_name = "election" , election_description = "description" - , election_PublicKey = elecPubKey + , election_crypto = ElectionCrypto_FFC ffc elecPubKey , election_questions = quests , election_uuid = uuid - , election_hash = Hash "" -- FIXME: when implemented + , election_hash = hashJSON JSON.Null } verifyBallot elec <$> encryptBallot elec (Just ballotSecKey) opins diff --git a/tests/HUnit/FFC.hs b/tests/HUnit/FFC.hs new file mode 100644 --- /dev/null +++ b/tests/HUnit/FFC.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +module HUnit.FFC where + +import GHC.Natural (minusNaturalMaybe) +import Data.Maybe (fromJust) +import Test.Tasty.HUnit +import Voting.Protocol +import Utils + +hunit :: TestTree +hunit = 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) + ] + ] + , testGroup "hash" + [ testGroup "WeakParams" $ + reify weakFFC $ \(Proxy::Proxy c) -> + [ testCase "[groupGen]" $ + hash "start" [groupGen @c] @?= + fromNatural 100 + , testCase "[groupGen, groupGen]" $ + hash "start" [groupGen @c, groupGen] @?= + fromNatural 16 + ] + , testGroup "BeleniosParams" $ + reify beleniosFFC $ \(Proxy::Proxy c) -> + [ testCase "[groupGen]" $ + hash "start" [groupGen @c] @?= + fromNatural 1832875488615060263192702367259 + , testCase "[groupGen, groupGen]" $ + hash "start" [groupGen @c, groupGen] @?= + fromNatural 2495277906542783643199702546512 + ] + ] + ] 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 @@ -1,10 +1,10 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module HUnit.Trustee.Indispensable where import Test.Tasty.HUnit +import qualified Data.Text as Text import qualified System.Random as Random import qualified Text.Printf as Printf @@ -15,53 +15,52 @@ hunit :: TestTree hunit = testGroup "Indispensable" [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testsVerifyIndispensableTrusteePublicKey @WeakParams + [ testsVerifyIndispensableTrusteePublicKey weakFFC ] , testGroup "verifyTally" $ - [ testsVerifyTally @WeakParams - , testsVerifyTally @BeleniosParams + [ testsVerifyTally weakFFC + , testsVerifyTally beleniosFFC ] ] -testsVerifyIndispensableTrusteePublicKey :: forall q. Params q => TestTree -testsVerifyIndispensableTrusteePublicKey = - testGroup (paramsName @q) - [ testVerifyIndispensableTrusteePublicKey @q 0 (Right ()) +testsVerifyIndispensableTrusteePublicKey :: FFC -> TestTree +testsVerifyIndispensableTrusteePublicKey ffc = + testGroup (Text.unpack $ ffc_name ffc) + [ testVerifyIndispensableTrusteePublicKey ffc 0 (Right ()) ] testVerifyIndispensableTrusteePublicKey :: - forall q. Params q => - Int -> Either ErrorTrusteePublicKey () -> TestTree -testVerifyIndispensableTrusteePublicKey seed exp = + FFC -> Int -> Either ErrorTrusteePublicKey () -> TestTree +testVerifyIndispensableTrusteePublicKey ffc seed exp = let got = + reify ffc $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - trusteeSecKey :: SecretKey q <- randomSecretKey + trusteeSecKey :: SecretKey c <- randomSecretKey trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey lift $ verifyIndispensableTrusteePublicKey trusteePubKey in - testCase (show (paramsName @q)) $ + testCase (Text.unpack $ ffc_name ffc) $ got @?= exp -testsVerifyTally :: forall q. Params q => TestTree -testsVerifyTally = - testGroup (paramsName @q) - [ testVerifyTally @q 0 1 1 1 - , testVerifyTally @q 0 2 1 1 - , testVerifyTally @q 0 1 2 1 - , testVerifyTally @q 0 2 2 1 - , testVerifyTally @q 0 5 10 5 +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 ] -testVerifyTally :: - forall q. Params q => - Int -> Natural -> Natural -> Natural -> TestTree -testVerifyTally seed nTrustees nQuests nChoices = +testVerifyTally :: FFC -> Int -> Natural -> Natural -> Natural -> TestTree +testVerifyTally ffc seed nTrustees nQuests nChoices = let clearTallyResult = dummyTallyResult nQuests nChoices in - let decryptedTallyResult :: Either ErrorDecryptionShare [[Natural]] = + let decryptedTallyResult :: Either ErrorTally [[Natural]] = + reify ffc $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - secKeyByTrustee :: [SecretKey q] <- + secKeyByTrustee :: [SecretKey c] <- replicateM (fromIntegral nTrustees) $ randomSecretKey trusteePubKeys <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey let pubKeyByTrustee = trustee_PublicKey <$> trusteePubKeys @@ -71,12 +70,12 @@ lift $ verifyDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee tally@Tally{..} <- lift $ proveTally (encTally, countMax) decShareByTrustee $ - combineIndispensableDecryptionShares pubKeyByTrustee encTally + combineIndispensableDecryptionShares pubKeyByTrustee lift $ verifyTally tally $ - combineIndispensableDecryptionShares pubKeyByTrustee encTally + combineIndispensableDecryptionShares pubKeyByTrustee return tally_countByChoiceByQuest in - testCase (Printf.printf "nT=%i,nQ=%i,nC=%i (%i maxCount)" + testCase (Printf.printf "#T=%i,#Q=%i,#C=%i (%i maxCount)" nTrustees nQuests nChoices (dummyTallyCount nQuests nChoices)) $ decryptedTallyResult @?= Right clearTallyResult @@ -91,8 +90,9 @@ ] encryptTallyResult :: - Monad m => RandomGen r => SubGroup q => - PublicKey q -> [[Natural]] -> StateT r m (EncryptedTally q, Natural) + Reifies c FFC => + Monad m => RandomGen r => + PublicKey c -> [[Natural]] -> StateT r m (EncryptedTally c, Natural) encryptTallyResult pubKey countByChoiceByQuest = (`runStateT` 0) $ forM countByChoiceByQuest $ diff --git a/tests/QuickCheck/Election.hs b/tests/QuickCheck/Election.hs --- a/tests/QuickCheck/Election.hs +++ b/tests/QuickCheck/Election.hs @@ -1,14 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances {-# OPTIONS -fno-warn-orphans #-} module QuickCheck.Election where -import Test.Tasty.QuickCheck -import qualified Data.List as List -import qualified Data.Text as Text import Data.Eq (Eq(..)) import Data.Int (Int) +import Data.Maybe (fromJust) import Data.Ord (Ord(..)) +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 import Voting.Protocol @@ -18,80 +22,86 @@ maxArbitraryChoices :: Natural maxArbitraryChoices = 5 maxArbitraryQuestions :: Natural -maxArbitraryQuestions = 5 +maxArbitraryQuestions = 2 quickcheck :: TestTree quickcheck = testGroup "Election" [ testGroup "verifyBallot" $ - [ testElection @WeakParams - , testElection @BeleniosParams + [ testElection weakFFC + , testElection beleniosFFC ] ] -testElection :: forall q. Params q => TestTree -testElection = - testGroup (paramsName @q) - [ testProperty "verifyBallot" $ \(seed, (elec::Election q) :> votes) -> +testElection :: FFC -> TestTree +testElection ffc = + reify ffc $ \(Proxy::Proxy c) -> + testGroup (Text.unpack $ ffc_name ffc) + [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do - -- ballotSecKey :: SecretKey q <- randomSecretKey + -- ballotSecKey :: SecretKey c <- randomSecretKey ballot <- encryptBallot elec Nothing votes unless (verifyBallot elec ballot) $ lift $ throwE $ ErrorBallot_Wrong ] -instance PrimeField p => Arbitrary (F p) where - arbitrary = choose (zero, F (fieldCharac @p) - one) -instance SubGroup q => Arbitrary (G q) where +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 arbitrary = do m <- arbitrary return (groupGen ^ m) -instance SubGroup q => Arbitrary (E q) where - arbitrary = E <$> choose (zero, groupOrder @q - one) +instance Reifies c FFC => Arbitrary (E c) where + arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one) instance Arbitrary UUID where arbitrary = do seed <- arbitrary (`evalStateT` mkStdGen seed) $ randomUUID -instance SubGroup q => Arbitrary (Proof q) where +instance Reifies c FFC => Arbitrary (Proof c) where arbitrary = do proof_challenge <- arbitrary proof_response <- arbitrary return Proof{..} -instance SubGroup q => Arbitrary (Question q) where +instance Arbitrary Question where arbitrary = do let question_text = "question" choices :: Natural <- choose (1, maxArbitraryChoices) let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]] - question_mini <- fromNatural <$> choose (0, choices) - question_maxi <- fromNatural <$> choose (nat question_mini, choices) + question_mini <- choose (0, choices) + question_maxi <- choose (nat question_mini, choices) return Question{..} shrink quest = [ quest{question_choices, question_mini, question_maxi} | question_choices <- shrinkList pure $ question_choices quest - , let nChoices = fromNatural $ fromIntegral $ List.length question_choices - , question_mini <- shrink $ min nChoices $ max zero $ question_mini quest - , question_maxi <- shrink $ min nChoices $ max question_mini $ question_maxi quest + , let nChoices = fromIntegral $ List.length question_choices + , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest + , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest ] -instance SubGroup q => Arbitrary (Election q) where +instance Reifies c FFC => Arbitrary (Election c) where arbitrary = do let election_name = "election" let election_description = "description" - election_PublicKey <- arbitrary + election_crypto <- arbitrary election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary election_uuid <- arbitrary - let election_hash = Hash "" + let election_hash = hashJSON JSON.Null return Election{..} shrink elec = [ 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 SubGroup q => Arbitrary (Question q :> [Bool]) where +instance Arbitrary (Question :> [Bool]) where arbitrary = do quest@Question{..} <- arbitrary votes <- do @@ -104,7 +114,7 @@ [ q :> shrinkVotes q votes | q <- shrink quest ] -instance SubGroup q => Arbitrary (Election q :> [[Bool]]) where +instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where arbitrary = do elec@Election{..} <- arbitrary votes <- forM election_questions $ \Question{..} -> do @@ -136,7 +146,7 @@ -- | @('shrinkVotes' quest votes)@ -- returns a reduced version of the given @votes@ -- to fit the requirement of the given @quest@. -shrinkVotes :: Question q -> [Bool] -> [Bool] +shrinkVotes :: Question -> [Bool] -> [Bool] shrinkVotes Question{..} votes = (\(nTrue, b) -> nTrue <= nat question_maxi && b) <$> List.zip (countTrue votes) votes diff --git a/tests/QuickCheck/Trustee.hs b/tests/QuickCheck/Trustee.hs --- a/tests/QuickCheck/Trustee.hs +++ b/tests/QuickCheck/Trustee.hs @@ -1,10 +1,11 @@ {-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module QuickCheck.Trustee where import Test.Tasty.QuickCheck +import qualified Data.Text as Text import Voting.Protocol -import Voting.Protocol.Trustee.Indispensable import Utils import QuickCheck.Election () @@ -13,23 +14,24 @@ quickcheck = testGroup "Trustee" [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testIndispensableTrusteePublicKey @WeakParams - , testIndispensableTrusteePublicKey @BeleniosParams + [ testIndispensableTrusteePublicKey weakFFC + , testIndispensableTrusteePublicKey beleniosFFC ] ] -testIndispensableTrusteePublicKey :: forall q. Params q => TestTree -testIndispensableTrusteePublicKey = - testGroup (paramsName @q) +testIndispensableTrusteePublicKey :: FFC -> TestTree +testIndispensableTrusteePublicKey ffc = + reify ffc $ \(Proxy::Proxy c) -> + testGroup (Text.unpack $ ffc_name ffc) [ testProperty "Right" $ \seed -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do - trusteeSecKey :: SecretKey q <- randomSecretKey + trusteeSecKey :: SecretKey c <- randomSecretKey trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey lift $ verifyIndispensableTrusteePublicKey trusteePubKey ] -instance SubGroup q => Arbitrary (TrusteePublicKey q) where +instance Reifies c FFC => Arbitrary (TrusteePublicKey c) where arbitrary = do trustee_PublicKey <- arbitrary trustee_SecretKeyProof <- arbitrary diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -56,6 +56,7 @@ import Voting.Protocol.Utils +debug :: Show a => String -> a -> a debug msg x = trace (msg<>": "<>show x) x -- | @'nCk' n k@ returns the number of combinations