hjugement-protocol 0.0.9.20191031 → 0.0.10.20191104

raw patch · 18 files changed

+1117/−950 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• benchmarks/Election.hs +4/−4
• hjugement-protocol.cabal +4/−2
• src/Voting/Protocol.hs +8/−4
• src/Voting/Protocol/Arith.hs +0/−327
• src/Voting/Protocol/Arithmetic.hs +215/−0
• src/Voting/Protocol/Credential.hs +3/−7
• src/Voting/Protocol/Cryptography.hs +590/−0
• src/Voting/Protocol/Election.hs +47/−548
• src/Voting/Protocol/FFC.hs +18/−17
• src/Voting/Protocol/Tally.hs +24/−16
• src/Voting/Protocol/Trustee/Indispensable.hs +18/−11
• src/Voting/Protocol/Utils.hs +25/−1
• src/Voting/Protocol/Version.hs +148/−0
• tests/HUnit/Election.hs +2/−2
• tests/HUnit/FFC.hs +2/−2
• tests/HUnit/Trustee/Indispensable.hs +1/−1
• tests/QuickCheck/Election.hs +6/−6
• tests/QuickCheck/Trustee.hs +2/−2

@@ -13,7 +13,7 @@ makeElection ::  forall crypto v c.  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto =>  JSON.ToJSON crypto =>  Int -> Int -> Election crypto v c@@ -47,7 +47,7 @@  makeBallot ::  Reifies v Version =>- GroupParams crypto c => Key crypto =>+ CryptoParams crypto c => Key crypto =>  Election crypto v c -> Ballot crypto v c makeBallot elec = 	case runExcept $ (`evalStateT` mkStdGen seed) $ do@@ -69,7 +69,7 @@  benchEncryptBallot ::  forall crypto v c.- GroupParams crypto c =>+ CryptoParams crypto c =>  Reifies v Version =>  Key crypto =>  JSON.ToJSON crypto =>@@ -86,7 +86,7 @@ benchVerifyBallot ::  forall crypto v c.  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto =>  JSON.ToJSON crypto =>  NFData crypto =>

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.9.20191031+version: 0.0.10.20191104 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description:@@ -61,14 +61,16 @@   hs-source-dirs: src   exposed-modules:     Voting.Protocol-    Voting.Protocol.Arith+    Voting.Protocol.Arithmetic     Voting.Protocol.Credential+    Voting.Protocol.Cryptography     Voting.Protocol.Election     Voting.Protocol.FFC     Voting.Protocol.Tally     Voting.Protocol.Trustee     Voting.Protocol.Trustee.Indispensable     Voting.Protocol.Utils+    Voting.Protocol.Version   default-language: Haskell2010   default-extensions:     AllowAmbiguousTypes

@@ -1,22 +1,26 @@ module Voting.Protocol- ( module Voting.Protocol.Arith- , module Voting.Protocol.FFC+ ( module Voting.Protocol.Arithmetic+ , module Voting.Protocol.Version+ , module Voting.Protocol.Cryptography  , module Voting.Protocol.Credential  , module Voting.Protocol.Election  , module Voting.Protocol.Tally  , module Voting.Protocol.Trustee+ , module Voting.Protocol.FFC  , Natural  , RandomGen  , Reifies(..), reify  , Proxy(..)  ) where -import Voting.Protocol.Arith-import Voting.Protocol.FFC+import Voting.Protocol.Arithmetic+import Voting.Protocol.Cryptography+import Voting.Protocol.Version import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally import Voting.Protocol.Trustee+import Voting.Protocol.FFC  import Data.Proxy (Proxy(..)) import Data.Reflection (Reifies(..), reify)

@@ -1,327 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto-{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Arithmetic-module Voting.Protocol.Arith where--import Control.Arrow (first)-import Control.DeepSeq (NFData)-import Control.Monad (Monad(..))-import Data.Aeson (ToJSON(..),FromJSON(..))-import Data.Bits-import Data.Bool-import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldl')-import Data.Function (($), (.), id)-import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Maybe (Maybe(..), fromJust)-import Data.Ord (Ord(..))-import Data.Proxy (Proxy(..))-import Data.Reflection (Reifies(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import Data.Text (Text)-import GHC.Generics (Generic)-import GHC.Natural (minusNaturalMaybe)-import Numeric.Natural (Natural)-import Prelude (Integer, Integral(..), fromIntegral, Enum(..))-import Text.Read (readMaybe)-import Text.Show (Show(..))-import qualified Control.Monad.Trans.State.Strict as S-import qualified Crypto.Hash as Crypto-import qualified Data.Aeson as JSON-import qualified Data.Aeson.Types as JSON-import qualified Data.ByteArray as ByteArray-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as BS64-import qualified Data.Char as Char-import qualified Data.List as List-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Lazy.Builder.Int as TLB-import qualified Prelude as Num-import qualified System.Random as Random---- * Class 'Additive'-class Additive a where-	zero :: a-	(+) :: a -> a -> a; infixl 6 +-	sum :: Foldable f => f a -> a-	sum = foldl' (+) zero-instance Additive Natural where-	zero = 0-	(+)  = (Num.+)-instance Additive Integer where-	zero = 0-	(+)  = (Num.+)-instance Additive Int where-	zero = 0-	(+)  = (Num.+)---- ** Class 'Negable'-class Additive a => Negable a where-	neg :: a -> a-	(-) :: a -> a -> a; infixl 6 --	x-y = x + neg y-instance Negable Integer where-	neg  = Num.negate-instance Negable Int where-	neg  = Num.negate---- * Class 'Multiplicative'-class Multiplicative a where-	one :: a-	(*) :: a -> a -> a; infixl 7 *-instance Multiplicative Natural where-	one = 1-	(*) = (Num.*)-instance Multiplicative Integer where-	one = 1-	(*) = (Num.*)-instance Multiplicative Int where-	one = 1-	(*) = (Num.*)---- ** Class 'Invertible'-class Multiplicative a => Invertible a where-	inv :: a -> a-	(/) :: a -> a -> a; infixl 7 /-	x/y = x * inv y---- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.-(^) ::- forall crypto c.- Reifies c crypto =>- Multiplicative (G crypto c) =>- G crypto c -> E crypto c -> G crypto c-(^) b (E e)- | e == 0 = one- | otherwise = t * (b*b) ^ E (e`shiftR`1)-	where t | testBit e 0 = b-	        | otherwise   = one-infixr 8 ^---- * Class 'GroupParams' where-class- ( Multiplicative (G crypto c)- , Invertible     (G crypto c)- , FromNatural    (G crypto c)- , ToNatural      (G crypto c)- , Eq             (G crypto c)- , Ord            (G crypto c)- , Show           (G crypto c)- , NFData         (G crypto c)- , FromJSON       (G crypto c)- , ToJSON         (G crypto c)- , Reifies c crypto- ) => GroupParams crypto c where-	-- | A generator of the subgroup.-	groupGen   :: G crypto c-	-- | The order of the subgroup.-	groupOrder :: Proxy c -> Natural-	-	-- | 'groupGenPowers' returns the infinite list-	-- of powers of 'groupGen'.-	---	-- NOTE: In the 'GroupParams' class to keep-	-- computed values in memory across calls to 'groupGenPowers'.-	groupGenPowers :: [G crypto c]-	groupGenPowers = go one-		where go g = g : go (g * groupGen)-	-	-- | 'groupGenInverses' returns the infinite list-	-- of 'inv'erse powers of 'groupGen':-	-- @['groupGen' '^' 'neg' i | i <- [0..]]@,-	-- but by computing each value from the previous one.-	---	-- NOTE: In the 'GroupParams' class to keep-	-- computed values in memory across calls to 'groupGenInverses'.-	---	-- Used by 'intervalDisjunctions'.-	groupGenInverses :: [G crypto c]-	groupGenInverses = go one-		where-		invGen = inv $ groupGen-		go g = g : go (g * invGen)---- ** Class 'ReifyCrypto'-class ReifyCrypto crypto where-	-- | Like 'reify' but augmented with the 'GroupParams' constraint.-	reifyCrypto :: crypto -> (forall c. Reifies c crypto => GroupParams crypto c => Proxy c -> r) -> r---- ** Type 'G'--- | The type of the elements of a subgroup of a field.-newtype G crypto c = G { unG :: FieldElement crypto }---- *** Type family 'FieldElement'-type family FieldElement crypto :: *---- ** Type 'E'--- | An exponent of a (cyclic) subgroup of a field.--- The value is always in @[0..'groupOrder'-1]@.-newtype E crypto c = E { unE :: Natural }- deriving (Eq,Ord,Show)- deriving newtype NFData-instance ToJSON (E crypto c) where-	toJSON = JSON.toJSON . show . unE-instance GroupParams crypto c => FromJSON (E crypto c) where-	parseJSON (JSON.String s)-	 | Just (c0,_) <- Text.uncons s-	 , c0 /= '0'-	 , Text.all Char.isDigit s-	 , Just x <- readMaybe (Text.unpack s)-	 , x < groupOrder (Proxy @c)-	 = return (E x)-	parseJSON json = JSON.typeMismatch "Exponent" json-instance GroupParams crypto c => FromNatural (E crypto c) where-	fromNatural i =-		E $ abs $ i `mod` groupOrder (Proxy @c)-		where-		abs x | x < 0 = x + groupOrder (Proxy @c)-		      | otherwise = x-instance ToNatural (E crypto c) where-	nat = unE-instance GroupParams crypto c => Additive (E crypto c) where-	zero = E zero-	E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c)-instance GroupParams crypto c => Negable (E crypto c) where-	neg (E x)-	 | x == 0 = zero-	 | otherwise = E $ fromJust $ nat (groupOrder (Proxy @c))`minusNaturalMaybe`x-instance GroupParams crypto c => Multiplicative (E crypto c) where-	one = E one-	E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c)-instance GroupParams crypto c => Random.Random (E crypto c) where-	randomR (E lo, E hi) =-		first (E . fromIntegral) .-		Random.randomR-		 ( 0`max`toInteger lo-		 , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) )-	random =-		first (E . fromIntegral) .-		Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1)-instance GroupParams crypto c => Enum (E crypto c) where-	toEnum = fromNatural . fromIntegral-	fromEnum = fromIntegral . nat-	enumFromTo lo hi = List.unfoldr-	 (\i -> if i<=hi then Just (i, i+one) else Nothing) lo---- * Class 'FromNatural'-class FromNatural a where-	fromNatural :: Natural -> a---- * Class 'ToNatural'-class ToNatural a where-	nat :: a -> Natural-instance ToNatural Natural where-	nat = id---- | @('bytesNat' x)@ returns the serialization of 'x'.-bytesNat :: ToNatural n => n -> BS.ByteString-bytesNat = fromString . show . nat---- * Type 'Hash'-newtype Hash crypto c = Hash (E crypto c)- deriving newtype (Eq,Ord,Show,NFData)---- | @('hash' bs gs)@ returns as a number in 'GroupExponent'--- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs'--- prefixing the decimal representation of given subgroup elements 'gs',--- with a comma (",") intercalated between them.------ NOTE: to avoid any collision when the 'hash' function is used in different contexts,--- a message 'gs' is actually prefixed by a 'bs' indicating the context.------ Used by 'proveEncryption' and 'verifyEncryption',--- where the 'bs' usually contains the 'statement' to be proven,--- and the 'gs' contains the 'commitments'.-hash :: GroupParams crypto c => BS.ByteString -> [G crypto c] -> E crypto c-hash bs gs = do-	let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)-	let h = Crypto.hashWith Crypto.SHA256 s-	fromNatural $-		decodeBigEndian $ ByteArray.convert h---- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number.-decodeBigEndian :: BS.ByteString -> Natural-decodeBigEndian =-	BS.foldl'-	 (\acc b -> acc`shiftL`8 + fromIntegral b)-	 (0::Natural)---- ** Type 'Base64SHA256'-newtype Base64SHA256 = Base64SHA256 Text- deriving (Eq,Ord,Show,Generic)- deriving anyclass (ToJSON,FromJSON)- deriving newtype NFData---- | @('base64SHA256' bs)@ returns the 'Crypto.SHA256' hash--- of the given 'BS.ByteString' 'bs',--- as a 'Text' escaped in @base64@ encoding--- (<https://tools.ietf.org/html/rfc4648 RFC 4648>).-base64SHA256 :: BS.ByteString -> Base64SHA256-base64SHA256 bs =-	let h = Crypto.hashWith Crypto.SHA256 bs in-	Base64SHA256 $-		Text.takeWhile (/= '=') $ -- NOTE: no padding.-		Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h---- ** Type 'HexSHA256'-newtype HexSHA256 = HexSHA256 Text- deriving (Eq,Ord,Show,Generic)- deriving anyclass (ToJSON,FromJSON)- deriving newtype NFData--- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash--- of the given 'BS.ByteString' 'bs', escaped in hexadecimal--- into a 'Text' of 32 lowercase characters.------ Used (in retro-dependencies of this library) to hash--- the 'PublicKey' of a voter or a trustee.-hexSHA256 :: BS.ByteString -> Text-hexSHA256 bs =-	let h = Crypto.hashWith Crypto.SHA256 bs in-	let n = decodeBigEndian $ ByteArray.convert h in-	-- NOTE: always set the 256 bit then remove it-	-- to always have leading zeros,-	-- and thus always 64 characters wide hashes.-	TL.toStrict $-	TL.tail $ TLB.toLazyText $ TLB.hexadecimal $-	setBit n 256---- * Random---- | @('randomR' i)@ returns a random integer in @[0..i-1]@.-randomR ::- Monad m =>- Random.RandomGen r =>- Random.Random i =>- Negable i =>- Multiplicative i =>- i -> S.StateT r m i-randomR i = S.StateT $ return . Random.randomR (zero, i-one)---- | @('random')@ returns a random integer--- in the range determined by its type.-random ::- Monad m =>- Random.RandomGen r =>- Random.Random i =>- Negable i =>- Multiplicative i =>- S.StateT r m i-random = S.StateT $ return . Random.random--instance Random.Random Natural where-	randomR (mini,maxi) =-		first (fromIntegral::Integer -> Natural) .-		Random.randomR (fromIntegral mini, fromIntegral maxi)-	random = first (fromIntegral::Integer -> Natural) . Random.random

@@ -0,0 +1,215 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto+module Voting.Protocol.Arithmetic where++import Control.Arrow (first)+import Control.DeepSeq (NFData)+import Control.Monad (Monad(..))+import Data.Aeson (ToJSON(..),FromJSON(..))+import Data.Bits+import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (Foldable, foldl')+import Data.Function (($), (.), id)+import Data.Int (Int)+import Data.Maybe (Maybe(..), fromJust)+import Data.Ord (Ord(..))+import Data.Proxy (Proxy(..))+import Data.Reflection (Reifies(..))+import Data.String (IsString(..))+import GHC.Natural (minusNaturalMaybe)+import Numeric.Natural (Natural)+import Prelude (Integer, Bounded(..), Integral(..), fromIntegral, Enum(..))+import Text.Read (readMaybe)+import Text.Show (Show(..))+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+import qualified Data.ByteString as BS+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Prelude as Num+import qualified System.Random as Random++-- * Class 'CryptoParams' where+class+ ( EuclideanRing (G crypto c)+ , FromNatural   (G crypto c)+ , ToNatural     (G crypto c)+ , Eq            (G crypto c)+ , Ord           (G crypto c)+ , Show          (G crypto c)+ , NFData        (G crypto c)+ , FromJSON      (G crypto c)+ , ToJSON        (G crypto c)+ , Reifies c crypto+ ) => CryptoParams crypto c where+	-- | A generator of the subgroup.+	groupGen   :: G crypto c+	-- | The order of the subgroup.+	groupOrder :: Proxy c -> Natural+	+	-- | 'groupGenPowers' returns the infinite list+	-- of powers of 'groupGen'.+	--+	-- NOTE: In the 'CryptoParams' class to keep+	-- computed values in memory across calls to 'groupGenPowers'.+	groupGenPowers :: [G crypto c]+	groupGenPowers = go one+		where go g = g : go (g * groupGen)+	+	-- | 'groupGenInverses' returns the infinite list+	-- of 'inverse' powers of 'groupGen':+	-- @['groupGen' '^' 'negate' i | i <- [0..]]@,+	-- but by computing each value from the previous one.+	--+	-- NOTE: In the 'CryptoParams' class to keep+	-- computed values in memory across calls to 'groupGenInverses'.+	--+	-- Used by 'intervalDisjunctions'.+	groupGenInverses :: [G crypto c]+	groupGenInverses = go one+		where+		invGen = inverse groupGen+		go g = g : go (g * invGen)++-- ** Class 'ReifyCrypto'+class ReifyCrypto crypto where+	-- | Like 'reify' but augmented with the 'CryptoParams' constraint.+	reifyCrypto :: crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r++-- * Class 'Additive'+-- | An additive semigroup.+class Additive a where+	zero :: a+	(+) :: a -> a -> a; infixl 6 ++	sum :: Foldable f => f a -> a+	sum = foldl' (+) zero+instance Additive Natural where+	zero = 0+	(+)  = (Num.+)+instance Additive Integer where+	zero = 0+	(+)  = (Num.+)+instance Additive Int where+	zero = 0+	(+)  = (Num.+)++-- * Class 'Semiring'+-- | A multiplicative semigroup, with an additive semigroup (aka. a semiring).+class Additive a => Semiring a where+	one :: a+	(*) :: a -> a -> a; infixl 7 *+instance Semiring Natural where+	one = 1+	(*) = (Num.*)+instance Semiring Integer where+	one = 1+	(*) = (Num.*)+instance Semiring Int where+	one = 1+	(*) = (Num.*)++-- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.+(^) ::+ forall crypto c.+ Reifies c crypto =>+ Semiring (G crypto c) =>+ G crypto c -> E crypto c -> G crypto c+(^) b (E e)+ | e == 0 = one+ | otherwise = t * (b*b) ^ E (e`shiftR`1)+	where t | testBit e 0 = b+	        | otherwise   = one+infixr 8 ^++-- ** Class 'Ring'+-- | A semiring that support substraction (aka. a ring).+class Semiring a => Ring a where+	negate :: a -> a+	(-) :: a -> a -> a; infixl 6 -+	x-y = x + negate y+instance Ring Integer where+	negate  = Num.negate+instance Ring Int where+	negate  = Num.negate++-- ** Class 'EuclideanRing'+-- | A commutative ring that support division (aka. an euclidean ring).+class Ring a => EuclideanRing a where+	inverse :: a -> a+	(/) :: a -> a -> a; infixl 7 /+	x/y = x * inverse y++-- ** Type 'G'+-- | The type of the elements of a subgroup of a field.+newtype G crypto c = G { unG :: FieldElement crypto }++-- *** Type family 'FieldElement'+type family FieldElement crypto :: *++-- ** Type 'E'+-- | An exponent of a (cyclic) subgroup of a field.+-- The value is always in @[0..'groupOrder'-1]@.+newtype E crypto c = E { unE :: Natural }+ deriving (Eq,Ord,Show)+ deriving newtype NFData+instance ToJSON (E crypto c) where+	toJSON = JSON.toJSON . show . unE+instance CryptoParams crypto c => FromJSON (E crypto c) where+	parseJSON (JSON.String s)+	 | Just (c0,_) <- Text.uncons s+	 , c0 /= '0'+	 , Text.all Char.isDigit s+	 , Just x <- readMaybe (Text.unpack s)+	 , x < groupOrder (Proxy @c)+	 = return (E x)+	parseJSON json = JSON.typeMismatch "Exponent" json+instance CryptoParams crypto c => FromNatural (E crypto c) where+	fromNatural n = E $ n `mod` groupOrder (Proxy @c)+instance ToNatural (E crypto c) where+	nat = unE+instance CryptoParams crypto c => Additive (E crypto c) where+	zero = E zero+	E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c)+instance CryptoParams crypto c => Semiring (E crypto c) where+	one = E one+	E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c)+instance CryptoParams crypto c => Ring (E crypto c) where+	negate (E x) = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`x+instance CryptoParams crypto c => Random.Random (E crypto c) where+	randomR (E lo, E hi) =+		first (E . fromIntegral) .+		Random.randomR+		 ( 0`max`toInteger lo+		 , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) )+	random =+		first (E . fromIntegral) .+		Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1)+instance CryptoParams crypto c => Enum (E crypto c) where+	toEnum = fromNatural . fromIntegral+	fromEnum = fromIntegral . nat+	enumFromTo lo hi = List.unfoldr+	 (\i -> if i<=hi then Just (i, i+one) else Nothing) lo+instance CryptoParams crypto c => Bounded (E crypto c) where+	minBound = zero+	maxBound = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`1++-- * Class 'FromNatural'+class FromNatural a where+	fromNatural :: Natural -> a+instance FromNatural Natural where+	fromNatural = id++-- * Class 'ToNatural'+class ToNatural a where+	nat :: a -> Natural+instance ToNatural Natural where+	nat = id++-- | @('bytesNat' x)@ returns the serialization of 'x'.+bytesNat :: ToNatural n => n -> BS.ByteString+bytesNat = fromString . show . nat

@@ -28,7 +28,8 @@ import qualified Data.Text as Text import qualified System.Random as Random -import Voting.Protocol.Arith+import Voting.Protocol.Arithmetic+import Voting.Protocol.Cryptography  -- * Class 'Key' class Key crypto where@@ -54,11 +55,6 @@ 	 SecretKey crypto c -> 	 PublicKey crypto c --- ** Type 'PublicKey'-type PublicKey = G--- ** Type 'SecretKey'-type SecretKey = E- -- * Type 'Credential' -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters -- from a base alphabet of (@'tokenBase' '==' 58)@ characters:@@ -91,7 +87,7 @@ 			( acc * tokenBase + d 			, charOfDigit d : ds ) 		 ) (zero::Int, []) rs-	let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?+	let checksum = (negate tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ? 	return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs) 	where 	charOfDigit = (credentialAlphabet List.!!)

@@ -0,0 +1,590 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances+module Voting.Protocol.Cryptography where++import Control.DeepSeq (NFData)+import Control.Monad (Monad(..), join, replicateM)+import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=))+import Data.Bits+import Data.Bool+import Data.Eq (Eq(..))+import Data.Function (($), (.))+import Data.Functor (Functor, (<$>))+import Data.Maybe (Maybe(..), fromJust)+import Data.Ord (Ord(..))+import Data.Proxy (Proxy(..))+import Data.Reflection (Reifies(..))+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..))+import Data.Text (Text)+import GHC.Generics (Generic)+import GHC.Natural (minusNaturalMaybe)+import Numeric.Natural (Natural)+import Prelude (Bounded(..), fromIntegral)+import System.Random (RandomGen)+import Text.Show (Show(..))+import qualified Control.Monad.Trans.State.Strict as S+import qualified Crypto.Hash as Crypto+import qualified Data.Aeson as JSON+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as BS64+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Builder.Int as TLB+import qualified System.Random as Random++import Voting.Protocol.Utils+import Voting.Protocol.Arithmetic+import Voting.Protocol.Version++-- ** Type 'PublicKey'+type PublicKey = G+-- ** Type 'SecretKey'+type SecretKey = E++-- * Type 'Hash'+newtype Hash crypto c = Hash (E crypto c)+ deriving newtype (Eq,Ord,Show,NFData)++-- | @('hash' bs gs)@ returns as a number in 'E'+-- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs'+-- prefixing the decimal representation of given subgroup elements 'gs',+-- with a comma (",") intercalated between them.+--+-- NOTE: to avoid any collision when the 'hash' function is used in different contexts,+-- a message 'gs' is actually prefixed by a 'bs' indicating the context.+--+-- Used by 'proveEncryption' and 'verifyEncryption',+-- where the 'bs' usually contains the 'statement' to be proven,+-- and the 'gs' contains the 'commitments'.+hash :: CryptoParams crypto c => BS.ByteString -> [G crypto c] -> E crypto c+hash bs gs = do+	let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)+	let h = Crypto.hashWith Crypto.SHA256 s+	fromNatural $+		decodeBigEndian $ ByteArray.convert h++-- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number.+decodeBigEndian :: BS.ByteString -> Natural+decodeBigEndian =+	BS.foldl'+	 (\acc b -> acc`shiftL`8 + fromIntegral b)+	 (0::Natural)++-- ** Type 'Base64SHA256'+newtype Base64SHA256 = Base64SHA256 Text+ deriving (Eq,Ord,Show,Generic)+ deriving anyclass (ToJSON,FromJSON)+ deriving newtype NFData++-- | @('base64SHA256' bs)@ returns the 'Crypto.SHA256' hash+-- of the given 'BS.ByteString' 'bs',+-- as a 'Text' escaped in @base64@ encoding+-- (<https://tools.ietf.org/html/rfc4648 RFC 4648>).+base64SHA256 :: BS.ByteString -> Base64SHA256+base64SHA256 bs =+	let h = Crypto.hashWith Crypto.SHA256 bs in+	Base64SHA256 $+		Text.takeWhile (/= '=') $ -- NOTE: no padding.+		Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h++-- ** Type 'HexSHA256'+newtype HexSHA256 = HexSHA256 Text+ deriving (Eq,Ord,Show,Generic)+ deriving anyclass (ToJSON,FromJSON)+ deriving newtype NFData+-- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash+-- of the given 'BS.ByteString' 'bs', escaped in hexadecimal+-- into a 'Text' of 32 lowercase characters.+--+-- Used (in retro-dependencies of this library) to hash+-- the 'PublicKey' of a voter or a trustee.+hexSHA256 :: BS.ByteString -> Text+hexSHA256 bs =+	let h = Crypto.hashWith Crypto.SHA256 bs in+	let n = decodeBigEndian $ ByteArray.convert h in+	-- NOTE: always set the 256 bit then remove it+	-- to always have leading zeros,+	-- and thus always 64 characters wide hashes.+	TL.toStrict $+	TL.tail $ TLB.toLazyText $ TLB.hexadecimal $+	setBit n 256++-- * Random++-- | @('randomR' i)@ returns a random integer in @[0..i-1]@.+randomR ::+ Monad m =>+ Random.RandomGen r =>+ Random.Random i =>+ Ring i =>+ i -> S.StateT r m i+randomR i = S.StateT $ return . Random.randomR (zero, i-one)++-- | @('random')@ returns a random integer+-- in the range determined by its type.+random ::+ Monad m =>+ Random.RandomGen r =>+ Random.Random i =>+ Bounded i =>+ S.StateT r m i+random = S.StateT $ return . Random.random++-- * Type 'Encryption'+-- | ElGamal-like encryption.+-- Its security relies on the /Discrete Logarithm problem/.+--+-- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),+-- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@+-- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,+-- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")+-- to enable the additive homomorphism.+--+-- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,+-- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.+data Encryption crypto v c = Encryption+ { encryption_nonce :: !(G crypto c)+   -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,+   -- equal to @('groupGen' '^'encNonce)@+ , encryption_vault :: !(G crypto c)+   -- ^ Encrypted 'clear' text,+   -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@+ } deriving (Generic)+deriving instance Eq (G crypto c) => Eq (Encryption crypto v c)+deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c)+deriving instance NFData (G crypto c) => NFData (Encryption crypto v c)+instance+ ( Reifies v Version+ , CryptoParams crypto c+ ) => ToJSON (Encryption crypto v c) where+	toJSON Encryption{..} =+		JSON.object+		 [ "alpha" .= encryption_nonce+		 , "beta"  .= encryption_vault+		 ]+	toEncoding Encryption{..} =+		JSON.pairs+		 (  "alpha" .= encryption_nonce+		 <> "beta"  .= encryption_vault+		 )+instance+ ( Reifies v Version+ , CryptoParams crypto c+ ) => FromJSON (Encryption crypto v c) where+	parseJSON = JSON.withObject "Encryption" $ \o -> do+		encryption_nonce <- o .: "alpha"+		encryption_vault <- o .: "beta"+		return Encryption{..}++-- | Additive homomorphism.+-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.+instance CryptoParams crypto c => Additive (Encryption crypto v c) where+	zero = Encryption one one+	x+y = Encryption+	 (encryption_nonce x * encryption_nonce y)+	 (encryption_vault x * encryption_vault y)++-- *** Type 'EncryptionNonce'+type EncryptionNonce = E++-- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.+--+-- WARNING: the secret encryption nonce (@encNonce@)+-- is returned alongside the 'Encryption'+-- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',+-- but this secret @encNonce@ MUST be forgotten after that,+-- as it may be used to decipher the 'Encryption'+-- without the 'SecretKey' associated with 'pubKey'.+encrypt ::+ Reifies v Version =>+ CryptoParams crypto c =>+ Monad m => RandomGen r =>+ PublicKey crypto c -> E crypto c ->+ S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c)+encrypt pubKey clear = do+	encNonce <- random+	-- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.+	return $ (encNonce,)+		Encryption+		 { encryption_nonce = groupGen^encNonce+		 , encryption_vault = pubKey  ^encNonce * groupGen^clear+		 }++-- * Type 'Proof'+-- | Non-Interactive Zero-Knowledge 'Proof'+-- of knowledge of a discrete logarithm:+-- @(secret == logBase base (base^secret))@.+data Proof crypto v c = Proof+ { proof_challenge :: !(Challenge crypto c)+   -- ^ 'Challenge' sent by the verifier to the prover+   -- to ensure that the prover really has knowledge+   -- of the secret and is not replaying.+   -- Actually, 'proof_challenge' is not sent to the prover,+   -- but derived from the prover's 'Commitment's and statements+   -- with a collision resistant 'hash'.+   -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.+ , proof_response :: !(E crypto c)+   -- ^ A discrete logarithm sent by the prover to the verifier,+   -- as a response to 'proof_challenge'.+   --+   -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:+   --+   -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,+   -- * @commitment '==' 'commit' proof base basePowSec '=='+   --   base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,+   -- * and @basePowSec '==' base'^'sec@,+   --+   -- then, with overwhelming probability (due to the 'hash' function),+   -- the prover was not able to choose 'proof_challenge'+   -- yet was able to compute a 'proof_response' such that+   -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),+   -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,+   -- therefore the prover knows 'sec'.+   --+   -- The prover choses 'commitment' to be a random power of @base@,+   -- to ensure that each 'prove' does not reveal any information+   -- about its secret.+ } deriving (Eq,Show,NFData,Generic)+instance Reifies v Version => ToJSON (Proof crypto v c) where+	toJSON Proof{..} =+		JSON.object+		 [ "challenge" .= proof_challenge+		 , "response"  .= proof_response+		 ]+	toEncoding Proof{..} =+		JSON.pairs+		 (  "challenge" .= proof_challenge+		 <> "response"  .= proof_response+		 )+instance+ ( CryptoParams crypto c+ , Reifies v Version+ ) => FromJSON (Proof crypto v c) where+	parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do+		proof_challenge <- o .: "challenge"+		proof_response  <- o .: "response"+		return Proof{..}++-- ** Type 'ZKP'+-- | Zero-knowledge proof.+--+-- A protocol is /zero-knowledge/ if the verifier+-- learns nothing from the protocol except that the prover+-- knows the secret.+--+-- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:+--      A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.+newtype ZKP = ZKP BS.ByteString++-- ** Type 'Challenge'+type Challenge = E++-- ** Type 'Oracle'+-- An 'Oracle' returns the 'Challenge' of the 'Commitment's+-- by 'hash'ing them (eventually with other 'Commitment's).+--+-- Used in 'prove' it enables a Fiat-Shamir transformation+-- of an /interactive zero-knowledge/ (IZK) proof+-- into a /non-interactive zero-knowledge/ (NIZK) proof.+-- That is to say that the verifier does not have+-- to send a 'Challenge' to the prover.+-- Indeed, the prover now handles the 'Challenge'+-- which becomes a (collision resistant) 'hash'+-- of the prover's commitments (and statements to be a stronger proof).+type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c++-- | @('prove' sec commitmentBases oracle)@+-- returns a 'Proof' that @sec@ is known+-- (by proving the knowledge of its discrete logarithm).+--+-- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases'+-- raised to the power of the secret nonce of the 'Proof',+-- as those are the 'Commitment's that the verifier will obtain+-- when composing the 'proof_challenge' and 'proof_response' together+-- (with 'commit').+--+-- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):+-- the statement must be included in the 'hash' (along with the commitments).+--+-- NOTE: a 'random' @nonce@ is used to ensure each 'prove'+-- does not reveal any information regarding the secret @sec@,+-- because two 'Proof's using the same 'Commitment'+-- can be used to deduce @sec@ (using the special-soundness).+prove ::+ forall crypto v c list m r.+ Reifies v Version =>+ CryptoParams crypto c =>+ Monad m => RandomGen r => Functor list =>+ E crypto c ->+ list (G crypto c) ->+ Oracle list crypto c ->+ S.StateT r m (Proof crypto v c)+prove sec commitmentBases oracle = do+	nonce <- random+	let commitments = (^ nonce) <$> commitmentBases+	let proof_challenge = oracle commitments+	return Proof+	 { proof_challenge+	 , proof_response = nonce `op` (sec*proof_challenge)+	 }+	where+	-- | See comments in 'commit'.+	op =+		if reflect (Proxy @v) `hasVersionTag` versionTagQuicker+		then (-)+		else (+)++-- | Like 'prove' but quicker. It chould replace 'prove' entirely+-- when Helios-C specifications will be fixed.+proveQuicker ::+ Reifies v Version =>+ CryptoParams crypto c =>+ Monad m => RandomGen r => Functor list =>+ E crypto c ->+ list (G crypto c) ->+ Oracle list crypto c ->+ S.StateT r m (Proof crypto v c)+proveQuicker sec commitmentBases oracle = do+	nonce <- random+	let commitments = (^ nonce) <$> commitmentBases+	let proof_challenge = oracle commitments+	return Proof+	 { proof_challenge+	 , proof_response = nonce - sec*proof_challenge+	 }++-- | @('fakeProof')@ returns a 'Proof'+-- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,+-- instead of @('proof_challenge' '==' 'hash' statement commitments)@+-- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@+-- as a 'Proof' returned by 'prove'.+--+-- Used in 'proveEncryption' to fill the returned 'DisjProof'+-- with fake 'Proof's for all 'Disjunction's but the encrypted one.+fakeProof ::+ CryptoParams crypto c =>+ Monad m => RandomGen r =>+ S.StateT r m (Proof crypto v c)+fakeProof = do+	proof_challenge <- random+	proof_response  <- random+	return Proof{..}++-- ** Type 'Commitment'+-- | A commitment from the prover to the verifier.+-- It's a power of 'groupGen' chosen randomly by the prover+-- when making a 'Proof' with 'prove'.+type Commitment = G++-- | @('commit' proof base basePowSec)@ returns a 'Commitment'+-- from the given 'Proof' with the knowledge of the verifier.+commit ::+ forall crypto v c.+ Reifies v Version =>+ CryptoParams crypto c =>+ Proof crypto v c ->+ G crypto c ->+ G crypto c ->+ Commitment crypto c+commit Proof{..} base basePowSec =+	(base^proof_response) `op`+	(basePowSec^proof_challenge)+	where+	op =+		if reflect (Proxy @v) `hasVersionTag` versionTagQuicker+		then (*)+		else (/)+  -- TODO: contrary to some textbook presentations,+  -- @('*')@ should be used instead of @('/')@ to avoid the performance cost+  -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,+  -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.+{-# INLINE commit #-}++-- | Like 'commit' but quicker. It chould replace 'commit' entirely+-- when Helios-C specifications will be fixed.+commitQuicker ::+ CryptoParams crypto c =>+ Proof crypto v c ->+ G crypto c ->+ G crypto c ->+ Commitment crypto c+commitQuicker Proof{..} base basePowSec =+	base^proof_response *+	basePowSec^proof_challenge++-- * Type 'Disjunction'+-- | A 'Disjunction' is an 'inverse'd @('groupGen' '^'opinion)@+-- it's used in 'proveEncryption' to generate a 'Proof'+-- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,+type Disjunction = G++booleanDisjunctions ::+ forall crypto c.+ CryptoParams crypto c =>+ [Disjunction crypto c]+booleanDisjunctions = List.take 2 $ groupGenInverses @crypto++intervalDisjunctions ::+ forall crypto c.+ CryptoParams crypto c =>+ Natural -> Natural -> [Disjunction crypto c]+intervalDisjunctions mini maxi =+	List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $+	List.genericDrop (nat mini) $+	groupGenInverses @crypto++-- ** Type 'DisjProof'+-- | A list of 'Proof's to prove that the opinion within an 'Encryption'+-- is indexing a 'Disjunction' within a list of them,+-- without revealing which opinion it is.+newtype DisjProof crypto v c = DisjProof [Proof crypto v c]+ deriving (Eq,Show,Generic)+ deriving newtype (NFData)+deriving newtype instance Reifies v Version => ToJSON (DisjProof crypto v c)+deriving newtype instance (Reifies v Version, CryptoParams crypto c) => FromJSON (DisjProof crypto v c)++-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@+-- returns a 'DisjProof' that 'enc' 'encrypt's+-- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.+--+-- The prover proves that it knows an 'encNonce', such that:+-- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@+--+-- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.+--+-- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.+proveEncryption ::+ Reifies v Version =>+ CryptoParams crypto c =>+ Monad m => RandomGen r =>+ PublicKey crypto c -> ZKP ->+ ([Disjunction crypto c],[Disjunction crypto c]) ->+ (EncryptionNonce crypto c, Encryption crypto v c) ->+ S.StateT r m (DisjProof crypto v c)+proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do+	-- Fake proofs for all 'Disjunction's except the genuine one.+	prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof+	nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof+	let fakeChallengeSum =+		sum (proof_challenge <$> prevFakeProofs) ++		sum (proof_challenge <$> nextFakeProofs)+	let statement = encryptionStatement voterZKP enc+	genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->+		let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in+		let prevCommitments = validCommitments prevDisjs prevFakeProofs in+		let nextCommitments = validCommitments nextDisjs nextFakeProofs in+		let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in+		let challenge = hash statement commitments in+		let genuineChallenge = challenge - fakeChallengeSum in+		genuineChallenge+		-- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)+		-- thus (sum (proof_challenge <$> proofs) == challenge)+		-- as checked in 'verifyEncryption'.+	let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)+	return (DisjProof proofs)++verifyEncryption ::+ Reifies v Version =>+ CryptoParams crypto c =>+ Monad m =>+ PublicKey crypto c -> ZKP ->+ [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) ->+ ExceptT ErrorVerifyEncryption m Bool+verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =+	case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of+	 Nothing ->+		throwE $ ErrorVerifyEncryption_InvalidProofLength+		 (fromIntegral $ List.length proofs)+		 (fromIntegral $ List.length disjs)+	 Just commitments ->+		return $ challengeSum ==+			hash (encryptionStatement voterZKP enc) (join commitments)+	where+	challengeSum = sum (proof_challenge <$> proofs)++-- ** Hashing+encryptionStatement ::+ CryptoParams crypto c =>+ ZKP -> Encryption crypto v c -> BS.ByteString+encryptionStatement (ZKP voterZKP) Encryption{..} =+	"prove|"<>voterZKP<>"|"+	 <> bytesNat encryption_nonce<>","+	 <> bytesNat encryption_vault<>"|"++-- | @('encryptionCommitments' elecPubKey enc disj proof)@+-- returns the 'Commitment's with only the knowledge of the verifier.+--+-- For the prover the 'Proof' comes from @fakeProof@,+-- and for the verifier the 'Proof' comes from the prover.+encryptionCommitments ::+ Reifies v Version =>+ CryptoParams crypto c =>+ PublicKey crypto c -> Encryption crypto v c ->+ Disjunction crypto c -> Proof crypto v c -> [G crypto c]+encryptionCommitments elecPubKey Encryption{..} disj proof =+	[ commit proof groupGen encryption_nonce+	  -- == groupGen ^ nonce if 'Proof' comes from 'prove'.+	  -- base==groupGen, basePowSec==groupGen^encNonce.+	, commit proof elecPubKey (encryption_vault*disj)+	  -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'+	  -- and 'encryption_vault' encrypts (- logBase groupGen disj).+	  -- base==elecPubKey, basePowSec==elecPubKey^encNonce.+	]++-- ** Type 'ErrorVerifyEncryption'+-- | Error raised by 'verifyEncryption'.+data ErrorVerifyEncryption+ =   ErrorVerifyEncryption_InvalidProofLength Natural Natural+     -- ^ When the number of proofs is different than+     -- the number of 'Disjunction's.+ deriving (Eq,Show)++-- * Type 'Signature'+-- | Schnorr-like signature.+--+-- Used by each voter to sign his/her encrypted 'Ballot'+-- using his/her 'Credential',+-- in order to avoid ballot stuffing.+data Signature crypto v c = Signature+ { signature_publicKey :: !(PublicKey crypto c)+   -- ^ Verification key.+ , signature_proof     :: !(Proof crypto v c)+ } deriving (Generic)+deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c)+instance+ ( Reifies v Version+ , CryptoParams crypto c+ ) => ToJSON (Signature crypto v c) where+	toJSON (Signature pubKey Proof{..}) =+		JSON.object+		 [ "public_key" .= pubKey+		 , "challenge"  .= proof_challenge+		 , "response"   .= proof_response+		 ]+	toEncoding (Signature pubKey Proof{..}) =+		JSON.pairs+		 (  "public_key" .= pubKey+		 <> "challenge"  .= proof_challenge+		 <> "response"   .= proof_response+		 )+instance+ ( Reifies v Version+ , CryptoParams crypto c+ ) => FromJSON (Signature crypto v c) where+	parseJSON = JSON.withObject "Signature" $ \o -> do+		signature_publicKey <- o .: "public_key"+		proof_challenge     <- o .: "challenge"+		proof_response      <- o .: "response"+		let signature_proof = Proof{..}+		return Signature{..}

@@ -3,29 +3,28 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} -- for readElection-{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances+{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances module Voting.Protocol.Election where -import Control.Applicative (Applicative(..), Alternative(..)) import Control.DeepSeq (NFData)-import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM)+import Control.Monad (Monad(..), mapM, zipWithM) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT) import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=)) import Data.Bool import Data.Either (either) import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldMap, and)+import Data.Foldable (foldMap, and) import Data.Function (($), (.), id, const)-import Data.Functor (Functor, (<$>), (<$))+import Data.Functor ((<$>)) import Data.Functor.Identity (Identity(..))-import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe)+import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.Reflection (Reifies(..), reify) import Data.Semigroup (Semigroup(..))-import Data.String (String, IsString(..))+import Data.String (String) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd)@@ -35,7 +34,7 @@ import Prelude (fromIntegral) import System.IO (IO, FilePath) import System.Random (RandomGen)-import Text.Show (Show(..), showChar, showString)+import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Aeson as JSON import qualified Data.Aeson.Encoding as JSON@@ -44,424 +43,13 @@ import qualified Data.Aeson.Types as JSON import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import qualified Data.Char as Char import qualified Data.List as List-import qualified Data.Text as Text-import qualified Text.ParserCombinators.ReadP as Read-import qualified Text.Read as Read  import Voting.Protocol.Utils-import Voting.Protocol.Arith+import Voting.Protocol.Arithmetic+import Voting.Protocol.Version import Voting.Protocol.Credential---- * Type 'Encryption'--- | ElGamal-like encryption.--- Its security relies on the /Discrete Logarithm problem/.------ Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),--- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@--- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,--- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")--- to enable the additive homomorphism.------ NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,--- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.-data Encryption crypto v c = Encryption- { encryption_nonce :: !(G crypto c)-   -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,-   -- equal to @('groupGen' '^'encNonce)@- , encryption_vault :: !(G crypto c)-   -- ^ Encrypted 'clear' text,-   -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@- } deriving (Generic)-deriving instance Eq (G crypto c) => Eq (Encryption crypto v c)-deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c)-deriving instance NFData (G crypto c) => NFData (Encryption crypto v c)-instance- ( Reifies v Version- , GroupParams crypto c- ) => ToJSON (Encryption crypto v c) where-	toJSON Encryption{..} =-		JSON.object-		 [ "alpha" .= encryption_nonce-		 , "beta"  .= encryption_vault-		 ]-	toEncoding Encryption{..} =-		JSON.pairs-		 (  "alpha" .= encryption_nonce-		 <> "beta"  .= encryption_vault-		 )-instance- ( Reifies v Version- , GroupParams crypto c- ) => FromJSON (Encryption crypto v c) where-	parseJSON = JSON.withObject "Encryption" $ \o -> do-		encryption_nonce <- o .: "alpha"-		encryption_vault <- o .: "beta"-		return Encryption{..}---- | Additive homomorphism.--- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.-instance GroupParams crypto c => Additive (Encryption crypto v c) where-	zero = Encryption one one-	x+y = Encryption-	 (encryption_nonce x * encryption_nonce y)-	 (encryption_vault x * encryption_vault y)---- *** Type 'EncryptionNonce'-type EncryptionNonce = E---- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.------ WARNING: the secret encryption nonce (@encNonce@)--- is returned alongside the 'Encryption'--- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',--- but this secret @encNonce@ MUST be forgotten after that,--- as it may be used to decipher the 'Encryption'--- without the 'SecretKey' associated with 'pubKey'.-encrypt ::- Reifies v Version =>- GroupParams crypto c =>- Monad m => RandomGen r =>- PublicKey crypto c -> E crypto c ->- S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c)-encrypt pubKey clear = do-	encNonce <- random-	-- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.-	return $ (encNonce,)-		Encryption-		 { encryption_nonce = groupGen^encNonce-		 , encryption_vault = pubKey  ^encNonce * groupGen^clear-		 }---- * Type 'Proof'--- | Non-Interactive Zero-Knowledge 'Proof'--- of knowledge of a discrete logarithm:--- @(secret == logBase base (base^secret))@.-data Proof crypto v c = Proof- { proof_challenge :: !(Challenge crypto c)-   -- ^ 'Challenge' sent by the verifier to the prover-   -- to ensure that the prover really has knowledge-   -- of the secret and is not replaying.-   -- Actually, 'proof_challenge' is not sent to the prover,-   -- but derived from the prover's 'Commitment's and statements-   -- with a collision resistant 'hash'.-   -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.- , proof_response :: !(E crypto c)-   -- ^ A discrete logarithm sent by the prover to the verifier,-   -- as a response to 'proof_challenge'.-   ---   -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:-   ---   -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,-   -- * @commitment '==' 'commit' proof base basePowSec '=='-   --   base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,-   -- * and @basePowSec '==' base'^'sec@,-   ---   -- then, with overwhelming probability (due to the 'hash' function),-   -- the prover was not able to choose 'proof_challenge'-   -- yet was able to compute a 'proof_response' such that-   -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),-   -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,-   -- therefore the prover knows 'sec'.-   ---   -- The prover choses 'commitment' to be a random power of @base@,-   -- to ensure that each 'prove' does not reveal any information-   -- about its secret.- } deriving (Eq,Show,NFData,Generic)-instance ToJSON (Proof crypto v c) where-	toJSON Proof{..} =-		JSON.object-		 [ "challenge" .= proof_challenge-		 , "response"  .= proof_response-		 ]-	toEncoding Proof{..} =-		JSON.pairs-		 (  "challenge" .= proof_challenge-		 <> "response"  .= proof_response-		 )-instance GroupParams crypto c => FromJSON (Proof crypto v c) where-	parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do-		proof_challenge <- o .: "challenge"-		proof_response  <- o .: "response"-		return Proof{..}---- ** Type 'ZKP'--- | Zero-knowledge proof.------ A protocol is /zero-knowledge/ if the verifier--- learns nothing from the protocol except that the prover--- knows the secret.------ DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:---      A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.-newtype ZKP = ZKP BS.ByteString---- ** Type 'Challenge'-type Challenge = E---- ** Type 'Oracle'--- An 'Oracle' returns the 'Challenge' of the 'Commitment's--- by 'hash'ing them (eventually with other 'Commitment's).------ Used in 'prove' it enables a Fiat-Shamir transformation--- of an /interactive zero-knowledge/ (IZK) proof--- into a /non-interactive zero-knowledge/ (NIZK) proof.--- That is to say that the verifier does not have--- to send a 'Challenge' to the prover.--- Indeed, the prover now handles the 'Challenge'--- which becomes a (collision resistant) 'hash'--- of the prover's commitments (and statements to be a stronger proof).-type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c---- | @('prove' sec commitmentBases oracle)@--- returns a 'Proof' that @sec@ is known--- (by proving the knowledge of its discrete logarithm).------ The 'Oracle' is given 'Commitment's equal to the 'commitmentBases'--- raised to the power of the secret nonce of the 'Proof',--- as those are the 'Commitment's that the verifier will obtain--- when composing the 'proof_challenge' and 'proof_response' together--- (with 'commit').------ WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):--- the statement must be included in the 'hash' (along with the commitments).------ NOTE: a 'random' @nonce@ is used to ensure each 'prove'--- does not reveal any information regarding the secret @sec@,--- because two 'Proof's using the same 'Commitment'--- can be used to deduce @sec@ (using the special-soundness).-prove ::- forall crypto v c list m r.- Reifies v Version =>- GroupParams crypto c =>- Monad m => RandomGen r => Functor list =>- E crypto c ->- list (G crypto c) ->- Oracle list crypto c ->- S.StateT r m (Proof crypto v c)-prove sec commitmentBases oracle = do-	nonce <- random-	let commitments = (^ nonce) <$> commitmentBases-	let proof_challenge = oracle commitments-	return Proof-	 { proof_challenge-	 , proof_response = nonce `op` (sec*proof_challenge)-	 }-	where-	-- | See comments in 'commit'.-	op =-		if reflect (Proxy @v) `hasVersionTag` versionTagQuicker-		then (-)-		else (+)---- | Like 'prove' but quicker. It chould replace 'prove' entirely--- when Helios-C specifications will be fixed.-proveQuicker ::- Reifies v Version =>- GroupParams crypto c =>- Monad m => RandomGen r => Functor list =>- E crypto c ->- list (G crypto c) ->- Oracle list crypto c ->- S.StateT r m (Proof crypto v c)-proveQuicker sec commitmentBases oracle = do-	nonce <- random-	let commitments = (^ nonce) <$> commitmentBases-	let proof_challenge = oracle commitments-	return Proof-	 { proof_challenge-	 , proof_response = nonce - sec*proof_challenge-	 }---- | @('fakeProof')@ returns a 'Proof'--- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,--- instead of @('proof_challenge' '==' 'hash' statement commitments)@--- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@--- as a 'Proof' returned by 'prove'.------ Used in 'proveEncryption' to fill the returned 'DisjProof'--- with fake 'Proof's for all 'Disjunction's but the encrypted one.-fakeProof ::- GroupParams crypto c =>- Monad m => RandomGen r =>- S.StateT r m (Proof crypto v c)-fakeProof = do-	proof_challenge <- random-	proof_response  <- random-	return Proof{..}---- ** Type 'Commitment'--- | A commitment from the prover to the verifier.--- It's a power of 'groupGen' chosen randomly by the prover--- when making a 'Proof' with 'prove'.-type Commitment = G---- | @('commit' proof base basePowSec)@ returns a 'Commitment'--- from the given 'Proof' with the knowledge of the verifier.-commit ::- forall crypto v c.- Reifies v Version =>- GroupParams crypto c =>- Proof crypto v c ->- G crypto c ->- G crypto c ->- Commitment crypto c-commit Proof{..} base basePowSec =-	(base^proof_response) `op`-	(basePowSec^proof_challenge)-	where-	op =-		if reflect (Proxy @v) `hasVersionTag` versionTagQuicker-		then (*)-		else (/)-  -- TODO: contrary to some textbook presentations,-  -- @('*')@ should be used instead of @('/')@ to avoid the performance cost-  -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,-  -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.-{-# INLINE commit #-}---- | Like 'commit' but quicker. It chould replace 'commit' entirely--- when Helios-C specifications will be fixed.-commitQuicker ::- GroupParams crypto c =>- Proof crypto v c ->- G crypto c ->- G crypto c ->- Commitment crypto c-commitQuicker Proof{..} base basePowSec =-	base^proof_response *-	basePowSec^proof_challenge---- * Type 'Disjunction'--- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@--- it's used in 'proveEncryption' to generate a 'Proof'--- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,-type Disjunction = G--booleanDisjunctions ::- forall crypto c.- GroupParams crypto c =>- [Disjunction crypto c]-booleanDisjunctions = List.take 2 $ groupGenInverses @crypto--intervalDisjunctions ::- forall crypto c.- GroupParams crypto c =>- Natural -> Natural -> [Disjunction crypto c]-intervalDisjunctions mini maxi =-	List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $-	List.genericDrop (nat mini) $-	groupGenInverses @crypto---- ** Type 'Opinion'--- | Index of a 'Disjunction' within a list of them.--- It is encrypted as a 'GroupExponent' by 'encrypt'.-type Opinion = E---- ** Type 'DisjProof'--- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'--- is indexing a 'Disjunction' within a list of them,--- without revealing which 'Opinion' it is.-newtype DisjProof crypto v c = DisjProof [Proof crypto v c]- deriving (Eq,Show,Generic)- deriving newtype (NFData,ToJSON,FromJSON)---- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@--- returns a 'DisjProof' that 'enc' 'encrypt's--- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.------ The prover proves that it knows an 'encNonce', such that:--- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@------ A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.------ DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.-proveEncryption ::- Reifies v Version =>- GroupParams crypto c =>- Monad m => RandomGen r =>- PublicKey crypto c -> ZKP ->- ([Disjunction crypto c],[Disjunction crypto c]) ->- (EncryptionNonce crypto c, Encryption crypto v c) ->- S.StateT r m (DisjProof crypto v c)-proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do-	-- Fake proofs for all 'Disjunction's except the genuine one.-	prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof-	nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof-	let fakeChallengeSum =-		sum (proof_challenge <$> prevFakeProofs) +-		sum (proof_challenge <$> nextFakeProofs)-	let statement = encryptionStatement voterZKP enc-	genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->-		let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in-		let prevCommitments = validCommitments prevDisjs prevFakeProofs in-		let nextCommitments = validCommitments nextDisjs nextFakeProofs in-		let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in-		let challenge = hash statement commitments in-		let genuineChallenge = challenge - fakeChallengeSum in-		genuineChallenge-		-- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)-		-- thus (sum (proof_challenge <$> proofs) == challenge)-		-- as checked in 'verifyEncryption'.-	let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)-	return (DisjProof proofs)--verifyEncryption ::- Reifies v Version =>- GroupParams crypto c =>- Monad m =>- PublicKey crypto c -> ZKP ->- [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) ->- ExceptT ErrorVerifyEncryption m Bool-verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =-	case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of-	 Nothing ->-		throwE $ ErrorVerifyEncryption_InvalidProofLength-		 (fromIntegral $ List.length proofs)-		 (fromIntegral $ List.length disjs)-	 Just commitments ->-		return $ challengeSum ==-			hash (encryptionStatement voterZKP enc) (join commitments)-	where-	challengeSum = sum (proof_challenge <$> proofs)---- ** Hashing-encryptionStatement ::- GroupParams crypto c =>- ZKP -> Encryption crypto v c -> BS.ByteString-encryptionStatement (ZKP voterZKP) Encryption{..} =-	"prove|"<>voterZKP<>"|"-	 <> bytesNat encryption_nonce<>","-	 <> bytesNat encryption_vault<>"|"---- | @('encryptionCommitments' elecPubKey enc disj proof)@--- returns the 'Commitment's with only the knowledge of the verifier.------ For the prover the 'Proof' comes from @fakeProof@,--- and for the verifier the 'Proof' comes from the prover.-encryptionCommitments ::- Reifies v Version =>- GroupParams crypto c =>- PublicKey crypto c -> Encryption crypto v c ->- Disjunction crypto c -> Proof crypto v c -> [G crypto c]-encryptionCommitments elecPubKey Encryption{..} disj proof =-	[ commit proof groupGen encryption_nonce-	  -- == groupGen ^ nonce if 'Proof' comes from 'prove'.-	  -- base==groupGen, basePowSec==groupGen^encNonce.-	, commit proof elecPubKey (encryption_vault*disj)-	  -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'-	  -- and 'encryption_vault' encrypts (- logBase groupGen disj).-	  -- base==elecPubKey, basePowSec==elecPubKey^encNonce.-	]---- ** Type 'ErrorVerifyEncryption'--- | Error raised by 'verifyEncryption'.-data ErrorVerifyEncryption- =   ErrorVerifyEncryption_InvalidProofLength Natural Natural-     -- ^ When the number of proofs is different than-     -- the number of 'Disjunction's.- deriving (Eq,Show)+import Voting.Protocol.Cryptography  -- * Type 'Question' data Question v = Question@@ -509,7 +97,7 @@ deriving instance NFData (G crypto c) => NFData (Answer crypto v c) instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  ) => ToJSON (Answer crypto v c) where 	toJSON Answer{..} = 		let (answer_choices, answer_individual_proofs) =@@ -529,7 +117,7 @@ 		 ) instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  ) => FromJSON (Answer crypto v c) where 	parseJSON = JSON.withObject "Answer" $ \o -> do 		answer_choices <- o .: "choices"@@ -543,7 +131,7 @@ -- unless an 'ErrorAnswer' is returned. encryptAnswer ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Monad m => RandomGen r =>  PublicKey crypto c -> ZKP ->  Question v -> [Bool] ->@@ -584,7 +172,7 @@  verifyAnswer ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  PublicKey crypto c -> ZKP ->  Question v -> Answer crypto v c -> Bool verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..}@@ -611,6 +199,11 @@      -- of 'question_mini' and 'question_maxi'.  deriving (Eq,Show,Generic,NFData) +-- ** Type 'Opinion'+-- | Index of a 'Disjunction' within a list of them.+-- It is encrypted as a 'GroupExponent' by 'encrypt'.+type Opinion = E+ -- * Type 'Election' data Election crypto v c = Election  { election_name        :: !Text@@ -627,7 +220,7 @@ deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c) instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  , ToJSON crypto  ) => ToJSON (Election crypto v c) where 	toJSON Election{..} =@@ -657,7 +250,7 @@  hashElection ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  ToJSON crypto =>  Election crypto v c -> Base64SHA256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode@@ -669,7 +262,7 @@  FilePath ->  (forall v c. 	Reifies v Version =>-	GroupParams crypto c =>+	CryptoParams crypto c => 	Election crypto v c -> r) ->  ExceptT String IO r readElection filePath k = do@@ -713,7 +306,7 @@ deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c) instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  , ToJSON (G crypto c)  ) => ToJSON (Ballot crypto v c) where 	toJSON Ballot{..} =@@ -732,7 +325,7 @@ 		 maybe mempty ("signature" .=) ballot_signature instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  ) => FromJSON (Ballot crypto v c) where 	parseJSON = JSON.withObject "Ballot" $ \o -> do 		ballot_answers       <- o .: "answers"@@ -747,7 +340,7 @@ -- on each 'question_choices' of each 'election_questions'. encryptBallot ::  Reifies v Version =>- GroupParams crypto c => Key crypto =>+ CryptoParams crypto c => Key crypto =>  Monad m => RandomGen r =>  Election crypto v c ->  Maybe (SecretKey crypto c) -> [[Bool]] ->@@ -780,8 +373,8 @@ 				 -- NOTE: the order is unusual, the commitments are first 				 -- then comes the statement. Best guess is that 				 -- this is easier to code due to their respective types.-				 (signatureCommitments @crypto voterZKP commitment)-				 (signatureStatement @crypto ballot_answers)+				 (ballotCommitments @crypto voterZKP commitment)+				 (ballotStatement @crypto ballot_answers) 		return $ Just Signature{..} 	return Ballot 	 { ballot_answers@@ -792,7 +385,7 @@  verifyBallot ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Election crypto v c ->  Ballot crypto v c -> Bool verifyBallot (Election{..}::Election crypto v c) Ballot{..} =@@ -806,72 +399,14 @@ 			let zkp = ZKP (bytesNat signature_publicKey) in 			(, zkp) $ 				proof_challenge signature_proof == hash-				 (signatureCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey))-				 (signatureStatement @crypto ballot_answers)+				 (ballotCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey))+				 (ballotStatement @crypto ballot_answers) 	in 	and $ isValidSign : 		List.zipWith (verifyAnswer election_public_key zkpSign) 		 election_questions ballot_answers --- ** Type 'Signature'--- | Schnorr-like signature.------ Used by each voter to sign his/her encrypted 'Ballot'--- using his/her 'Credential',--- in order to avoid ballot stuffing.-data Signature crypto v c = Signature- { signature_publicKey :: !(PublicKey crypto c)-   -- ^ Verification key.- , signature_proof     :: !(Proof crypto v c)- } deriving (Generic)-deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c)-instance- ( Reifies v Version- , GroupParams crypto c- ) => ToJSON (Signature crypto v c) where-	toJSON (Signature pubKey Proof{..}) =-		JSON.object-		 [ "public_key" .= pubKey-		 , "challenge"  .= proof_challenge-		 , "response"   .= proof_response-		 ]-	toEncoding (Signature pubKey Proof{..}) =-		JSON.pairs-		 (  "public_key" .= pubKey-		 <> "challenge"  .= proof_challenge-		 <> "response"   .= proof_response-		 )-instance- ( Reifies v Version- , GroupParams crypto c- ) => FromJSON (Signature crypto v c) where-	parseJSON = JSON.withObject "Signature" $ \o -> do-		signature_publicKey <- o .: "public_key"-		proof_challenge     <- o .: "challenge"-		proof_response      <- o .: "response"-		let signature_proof = Proof{..}-		return Signature{..} --- *** Hashing---- | @('signatureStatement' answers)@--- returns the encrypted material to be signed:--- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@.-signatureStatement :: GroupParams crypto c => Foldable f => f (Answer crypto v c) -> [G crypto c]-signatureStatement =-	foldMap $ \Answer{..} ->-		(`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->-			[encryption_nonce, encryption_vault]---- | @('signatureCommitments' voterZKP commitment)@-signatureCommitments ::- GroupParams crypto c =>- ToNatural (G crypto c) =>- ZKP -> Commitment crypto c -> BS.ByteString-signatureCommitments (ZKP voterZKP) commitment =-	"sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement-	 <> bytesNat commitment<>"|"- -- ** Type 'ErrorBallot' -- | Error raised by 'encryptBallot'. data ErrorBallot@@ -884,58 +419,22 @@      -- ^ TODO: to be more precise.  deriving (Eq,Show,Generic,NFData) --- * Type 'Version'--- | Version of the Helios-C protocol.-data Version = Version- { version_branch :: [Natural]- , version_tags   :: [(Text, Natural)]- } deriving (Eq,Ord,Generic,NFData)-instance IsString Version where-	fromString = fromJust . readVersion-instance Show Version where-	showsPrec _p Version{..} =-		List.foldr (.) id-		 (List.intersperse (showChar '.') $-			showsPrec 0 <$> version_branch) .-		List.foldr (.) id-		 ((\(t,n) -> showChar '-' . showString (Text.unpack t) .-			if n > 0 then showsPrec 0 n else id)-		 <$> version_tags)-instance ToJSON Version where-	toJSON     = toJSON     . show-	toEncoding = toEncoding . show-instance FromJSON Version where-	parseJSON (JSON.String s)-	 | Just v <- readVersion (Text.unpack s)-	 = return v-	parseJSON json = JSON.typeMismatch "Version" json--hasVersionTag :: Version -> Text -> Bool-hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)--experimentalVersion :: Version-experimentalVersion = stableVersion- {version_tags = [(versionTagQuicker,0)]}--stableVersion :: Version-stableVersion = "1.6"--versionTagQuicker :: Text-versionTagQuicker = "quicker"+-- ** Hashing -readVersion :: String -> Maybe Version-readVersion = parseReadP $ do-	version_branch <- Read.sepBy1-	 (Read.read <$> Read.munch1 Char.isDigit)-	 (Read.char '.')-	version_tags <- Read.many $ (,)-		 <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)-		 <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)-	return Version{..}+-- | @('ballotStatement' ballot)@+-- returns the encrypted material to be signed:+-- all the 'encryption_nonce's and 'encryption_vault's of the given 'ballot_answers'.+ballotStatement :: CryptoParams crypto c => [Answer crypto v c] -> [G crypto c]+ballotStatement =+	foldMap $ \Answer{..} ->+		(`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->+			[encryption_nonce, encryption_vault] -parseReadP :: Read.ReadP a -> String -> Maybe a-parseReadP p s =-	let p' = Read.readP_to_S p in-	listToMaybe $ do-		(x, "") <- p' s-		return x+-- | @('ballotCommitments' voterZKP commitment)@+ballotCommitments ::+ CryptoParams crypto c =>+ ToNatural (G crypto c) =>+ ZKP -> Commitment crypto c -> BS.ByteString+ballotCommitments (ZKP voterZKP) commitment =+	"sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement+	 <> bytesNat commitment<>"|"

@@ -14,7 +14,7 @@ import Control.Arrow (first) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), unless)-import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))+import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.:?), (.=)) import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..))@@ -41,7 +41,8 @@ import qualified Data.Text.Encoding as Text import qualified System.Random as Random -import Voting.Protocol.Arith+import Voting.Protocol.Arithmetic+import Voting.Protocol.Cryptography import Voting.Protocol.Credential  -- * Type 'FFC'@@ -62,12 +63,12 @@      -- ^ The prime number characteristic of a Finite Prime Field.      --      -- ElGamal's hardness to decrypt requires a large prime number-     -- to form the 'Multiplicative' subgroup.+     -- to form the multiplicative subgroup.  ,   ffc_groupGen :: !Natural-     -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field.+     -- ^ A generator of the multiplicative subgroup of the Finite Prime Field.      --      -- NOTE: since 'ffc_fieldCharac' is prime,-     -- the 'Multiplicative' subgroup is cyclic,+     -- the multiplicative subgroup is cyclic,      -- and there are phi('fieldCharac'-1) many choices for the generator of the group,      -- where phi is the Euler totient function.  ,   ffc_groupOrder :: !Natural@@ -116,7 +117,7 @@ 		unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $ 			JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o) 		return FFC{..}-instance Reifies c FFC => GroupParams FFC c where+instance Reifies c FFC => CryptoParams FFC c where 	groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c) 	groupOrder c = ffc_groupOrder $ reflect c instance ReifyCrypto FFC where@@ -151,7 +152,7 @@  -- | Parameters used in Belenios. -- A 2048-bit 'fieldCharac' of a Finite Prime Field,--- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup+-- with a 256-bit 'groupOrder' for a multiplicative subgroup -- generated by 'groupGen'. beleniosFFC :: FFC beleniosFFC = FFC@@ -166,10 +167,10 @@ -- A field must satisfy the following properties: -- -- * @(f, ('+'), 'zero')@ forms an abelian group,---   called the 'Additive' group of 'f'.+--   called the additive group of 'f'. -- -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,---   called the 'Multiplicative' group of 'f'.+--   called the multiplicative group of 'f'. -- -- * ('*') is associative: --   @(a'*'b)'*'c == a'*'(b'*'c)@ and@@ -212,13 +213,16 @@ instance Reifies c FFC => Additive (G FFC c) where 	zero = G 0 	G x + G y = G $ (x + y) `mod` fieldCharac @c-instance Reifies c FFC => Negable (G FFC c) where-	neg (G x)-	 | x == 0 = zero-	 | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x-instance Reifies c FFC => Multiplicative (G FFC c) where+instance Reifies c FFC => Semiring (G FFC c) where 	one = G 1 	G x * G y = G $ (x * y) `mod` fieldCharac @c+instance Reifies c FFC => Ring (G FFC c) where+	negate (G x)+	 | x == 0 = zero+	 | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x+instance Reifies c FFC => EuclideanRing (G FFC c) where+	-- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.+	inverse = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1)) instance Reifies c FFC => Random.Random (G FFC c) where 	randomR (G lo, G hi) = 		first (G . fromIntegral) .@@ -228,6 +232,3 @@ 	random = 		first (G . fromIntegral) . 		Random.randomR (0, toInteger (fieldCharac @c) - 1)-instance Reifies c FFC => Invertible (G FFC c) where-	-- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.-	inv = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1))

@@ -8,7 +8,7 @@ import Control.DeepSeq (NFData) import Control.Monad (Monad(..), mapM, unless) import Control.Monad.Trans.Except (Except, ExceptT, throwE)-import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.=))+import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=)) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>))@@ -29,7 +29,9 @@ import qualified Data.Map.Strict as Map  import Voting.Protocol.Utils-import Voting.Protocol.Arith+import Voting.Protocol.Arithmetic+import Voting.Protocol.Version+import Voting.Protocol.Cryptography import Voting.Protocol.Credential import Voting.Protocol.Election @@ -54,7 +56,7 @@ deriving instance NFData (G crypto c) => NFData (Tally crypto v c) instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  ) => ToJSON (Tally crypto v c) where 	toJSON Tally{..} = 		JSON.object@@ -72,7 +74,7 @@ 		 ) instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  ) => FromJSON (Tally crypto v c) where 	parseJSON = JSON.withObject "Tally" $ \o -> do 		tally_countMax             <- o .: "num_tallied"@@ -89,13 +91,13 @@ -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's. encryptedTally ::- GroupParams crypto c =>+ CryptoParams crypto c =>  [Ballot crypto v c] -> (EncryptedTally crypto v c, Natural) encryptedTally = List.foldr insertEncryptedTally emptyEncryptedTally  -- | The initial 'EncryptedTally' which tallies no 'Ballot'. emptyEncryptedTally ::- GroupParams crypto c =>+ CryptoParams crypto c =>  (EncryptedTally crypto v c, Natural) emptyEncryptedTally = (List.repeat (List.repeat zero), 0) @@ -103,7 +105,7 @@ -- returns the 'EncryptedTally' adding the votes of the given @(ballot)@ -- to those of the given @(encTally)@. insertEncryptedTally ::- GroupParams crypto c =>+ CryptoParams crypto c =>  Ballot crypto v c ->  (EncryptedTally crypto v c, Natural) ->  (EncryptedTally crypto v c, Natural)@@ -122,7 +124,7 @@  Except ErrorTally [[DecryptionFactor crypto c]]  proveTally ::- GroupParams crypto c =>+ CryptoParams crypto c =>  (EncryptedTally crypto v c, Natural) -> [DecryptionShare crypto v c] ->  DecryptionShareCombinator crypto v c -> Except ErrorTally (Tally crypto v c) proveTally@@ -146,7 +148,7 @@ 	return Tally{..}  verifyTally ::- GroupParams crypto c =>+ CryptoParams crypto c =>  Tally crypto v c ->  DecryptionShareCombinator crypto v c ->  Except ErrorTally ()@@ -171,7 +173,10 @@ deriving instance Eq (G crypto c) => Eq (DecryptionShare crypto v c) deriving instance Show (G crypto c) => Show (DecryptionShare crypto v c) deriving newtype instance NFData (G crypto c) => NFData (DecryptionShare crypto v c)-instance ToJSON (G crypto c) => ToJSON (DecryptionShare crypto v c) where+instance+ ( Reifies v Version+ , ToJSON (G crypto c)+ ) => ToJSON (DecryptionShare crypto v c) where 	toJSON (DecryptionShare decByChoiceByQuest) = 		JSON.object 		 [ "decryption_factors" .=@@ -185,7 +190,10 @@ 			 (JSON.list (JSON.list (toEncoding . fst)) decByChoiceByQuest) <> 			JSON.pair "decryption_proofs" 			 (JSON.list (JSON.list (toEncoding . snd)) decByChoiceByQuest)-instance GroupParams crypto c => FromJSON (DecryptionShare crypto v c) where+instance+ ( Reifies v Version+ , CryptoParams crypto c+ ) => FromJSON (DecryptionShare crypto v c) where 	parseJSON = JSON.withObject "DecryptionShare" $ \o -> do 		decFactors <- o .: "decryption_factors" 		decProofs  <- o .: "decryption_proofs"@@ -203,7 +211,7 @@ -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto =>  Monad m => RandomGen r =>  EncryptedTally crypto v c -> SecretKey crypto c -> S.StateT r m (DecryptionShare crypto v c)@@ -213,7 +221,7 @@  proveDecryptionFactor ::  Reifies v Version => - GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto =>  Monad m => RandomGen r =>  SecretKey crypto c -> Encryption crypto v c -> S.StateT r m (DecryptionFactor crypto c, Proof crypto v c)@@ -222,7 +230,7 @@ 	return (encryption_nonce^trusteeSecKey, proof) 	where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: GroupParams crypto c => PublicKey crypto c -> BS.ByteString+decryptionShareStatement :: CryptoParams crypto c => PublicKey crypto c -> BS.ByteString decryptionShareStatement pubKey = 	"decrypt|"<>bytesNat pubKey<>"|" @@ -248,7 +256,7 @@ -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Monad m =>  EncryptedTally crypto v c -> PublicKey crypto c -> DecryptionShare crypto v c ->  ExceptT ErrorTally m ()@@ -266,7 +274,7 @@  verifyDecryptionShareByTrustee ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Monad m =>  EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] ->  ExceptT ErrorTally m ()

@@ -7,7 +7,7 @@ import Control.DeepSeq (NFData) import Control.Monad (Monad(..), foldM, unless) import Control.Monad.Trans.Except (ExceptT(..), throwE)-import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.=))+import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=)) import Data.Eq (Eq(..)) import Data.Function (($)) import Data.Functor ((<$>))@@ -24,9 +24,10 @@ import qualified Data.List as List  import Voting.Protocol.Utils-import Voting.Protocol.Arith+import Voting.Protocol.Arithmetic+import Voting.Protocol.Version+import Voting.Protocol.Cryptography import Voting.Protocol.Credential-import Voting.Protocol.Election import Voting.Protocol.Tally  -- * Type 'TrusteePublicKey'@@ -50,7 +51,10 @@ deriving instance Eq (G crypto c) => Eq (TrusteePublicKey crypto v c) deriving instance (Show (G crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) deriving instance NFData (G crypto c) => NFData (TrusteePublicKey crypto v c)-instance ToJSON (G crypto c) => ToJSON (TrusteePublicKey crypto v c) where+instance+ ( Reifies v Version+ , ToJSON (G crypto c)+ ) => ToJSON (TrusteePublicKey crypto v c) where 	toJSON TrusteePublicKey{..} = 		JSON.object 		 [ "pok"        .= trustee_SecretKeyProof@@ -61,7 +65,10 @@ 		 (  "pok"        .= trustee_SecretKeyProof 		 <> "public_key" .= trustee_PublicKey 		 )-instance GroupParams crypto c => FromJSON (TrusteePublicKey crypto v c) where+instance+ ( Reifies v Version+ , CryptoParams crypto c+ ) => FromJSON (TrusteePublicKey crypto v c) where 	parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do 		trustee_PublicKey <- o .: "public_key" 		trustee_SecretKeyProof <- o .: "pok"@@ -74,7 +81,7 @@ -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto =>  Monad m => RandomGen r =>  SecretKey crypto c -> S.StateT r m (TrusteePublicKey crypto v c)@@ -93,7 +100,7 @@ -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Monad m =>  TrusteePublicKey crypto v c ->  ExceptT ErrorTrusteePublicKey m ()@@ -113,7 +120,7 @@  -- ** Hashing indispensableTrusteePublicKeyStatement ::- GroupParams crypto c =>+ CryptoParams crypto c =>  PublicKey crypto c -> BS.ByteString indispensableTrusteePublicKeyStatement trustPubKey = 	"pok|"<>bytesNat trustPubKey<>"|"@@ -123,7 +130,7 @@ -- ** Generating an 'Election''s 'PublicKey' from multiple 'TrusteePublicKey's.  combineIndispensableTrusteePublicKeys ::- GroupParams crypto c =>+ CryptoParams crypto c =>  [TrusteePublicKey crypto v c] -> PublicKey crypto c combineIndispensableTrusteePublicKeys = 	List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one@@ -132,7 +139,7 @@  verifyIndispensableDecryptionShareByTrustee ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Monad m =>  EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] ->  ExceptT ErrorTally m ()@@ -146,7 +153,7 @@ -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  [PublicKey crypto c] -> DecryptionShareCombinator crypto v c combineIndispensableDecryptionShares  pubKeyByTrustee

@@ -1,18 +1,25 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module Voting.Protocol.Utils where  import Control.Applicative (Applicative(..))+import Control.Arrow (first) import Data.Bool import Data.Either (Either(..), either) import Data.Eq (Eq(..)) import Data.Foldable (sequenceA_) import Data.Function (($), (.)) import Data.Functor ((<$))-import Data.Maybe (Maybe(..), maybe)+import Data.Maybe (Maybe(..), maybe, listToMaybe) import Data.String (String) import Data.Traversable (Traversable(..)) import Data.Tuple (uncurry)+import Numeric.Natural (Natural)+import Prelude (Integer, fromIntegral) import qualified Data.Aeson.Internal as JSON import qualified Data.List as List+import qualified System.Random as Random+import qualified Text.ParserCombinators.ReadP as Read+import qualified Text.Read as Read  -- | Like ('.') but with two arguments. o2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d@@ -62,8 +69,25 @@ 	maybe err sequenceA_ $ 		isoZipWith3 f as bs cs +-- * JSON utils+ -- | Copied from 'Data.Aeson''s 'eitherFormatError' -- which is not exported. jsonEitherFormatError :: Either (JSON.JSONPath, String) a -> Either String a jsonEitherFormatError = either (Left . uncurry JSON.formatError) Right {-# INLINE jsonEitherFormatError #-}++instance Random.Random Natural where+	randomR (mini,maxi) =+		first (fromIntegral::Integer -> Natural) .+		Random.randomR (fromIntegral mini, fromIntegral maxi)+	random = first (fromIntegral::Integer -> Natural) . Random.random++-- * Parsing utils++parseReadP :: Read.ReadP a -> String -> Maybe a+parseReadP p s =+	let p' = Read.readP_to_S p in+	listToMaybe $ do+		(x, "") <- p' s+		pure x

@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances+module Voting.Protocol.Version where++import Control.Applicative (Applicative(..), Alternative(..))+import Control.DeepSeq (NFData)+import Control.Monad (Monad(..), join, replicateM)+import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=))+import Data.Bits+import Data.Bool+import Data.Eq (Eq(..))+import Data.Function (($), (.), id)+import Data.Functor (Functor, (<$>), (<$))+import Data.Maybe (Maybe(..), fromJust, listToMaybe)+import Data.Ord (Ord(..))+import Data.Proxy (Proxy(..))+import Data.Reflection (Reifies(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Data.Text (Text)+import GHC.Generics (Generic)+import GHC.Natural (minusNaturalMaybe)+import GHC.TypeLits (Nat, Symbol, natVal, symbolVal, KnownNat, KnownSymbol)+import Numeric.Natural (Natural)+import Prelude (Bounded(..), fromIntegral)+import System.Random (RandomGen)+import Text.Show (Show(..), showChar, showString, shows)+import qualified Control.Monad.Trans.State.Strict as S+import qualified Crypto.Hash as Crypto+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as BS64+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Builder.Int as TLB+import qualified System.Random as Random+import qualified Text.ParserCombinators.ReadP as Read+import qualified Text.Read as Read++import Voting.Protocol.Utils+import Voting.Protocol.Arithmetic++-- * Type 'Version'+-- | Version of the Helios-C protocol.+data Version = Version+ { version_branch :: [Natural]+ , version_tags   :: [(Text, Natural)]+ } deriving (Eq,Ord,Generic,NFData)+instance IsString Version where+	fromString = fromJust . readVersion+instance Show Version where+	showsPrec _p Version{..} =+		List.foldr (.) id+		 (List.intersperse (showChar '.') $+			shows <$> version_branch) .+		List.foldr (.) id+		 ((\(t,n) -> showChar '-' . showString (Text.unpack t) .+			if n > 0 then shows n else id)+		 <$> version_tags)+instance ToJSON Version where+	toJSON     = toJSON     . show+	toEncoding = toEncoding . show+instance FromJSON Version where+	parseJSON (JSON.String s)+	 | Just v <- readVersion (Text.unpack s)+	 = return v+	parseJSON json = JSON.typeMismatch "Version" json++hasVersionTag :: Version -> Text -> Bool+hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)++-- ** Type 'ExperimentalVersion'+type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)]+experimentalVersion :: Version+experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}++-- ** Type 'StableVersion'+type StableVersion = V [1,6] '[]+stableVersion :: Version+stableVersion = "1.6"++-- ** Type 'VersionTagQuicker'+type VersionTagQuicker = "quicker"+versionTagQuicker :: Text+versionTagQuicker = "quicker"++readVersion :: String -> Maybe Version+readVersion = parseReadP $ do+	version_branch <- Read.sepBy1+	 (Read.read <$> Read.munch1 Char.isDigit)+	 (Read.char '.')+	version_tags <- Read.many $ (,)+		 <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)+		 <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)+	return Version{..}++-- ** Type 'V'+-- | Type-level representation of a specific 'Version'.+data V (branch::[Nat]) (tags::[(Symbol,Nat)])+-- | Like a normal 'reflect' but this one takes+-- its 'Version' from a type-level 'V'ersion+-- instead of a term-level 'Version'.+instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where+	reflect _ = Version+	 { version_branch = versionBranchVal (Proxy @branch)+	 , version_tags   = versionTagsVal (Proxy @tags)+	 }++-- *** Class 'VersionBranchVal'+class VersionBranchVal a where+	versionBranchVal :: proxy a -> [Natural]+instance KnownNat h => VersionBranchVal '[h] where+	versionBranchVal _ = [fromIntegral (natVal (Proxy @h))]+instance+ ( KnownNat h+ , KnownNat hh+ , VersionBranchVal (hh ':t)+ ) => VersionBranchVal (h ': hh ': t) where+	versionBranchVal _ =+		fromIntegral (natVal (Proxy @h)) :+		versionBranchVal (Proxy @(hh ':t))++-- *** Class 'VersionTagsVal'+class VersionTagsVal a where+	versionTagsVal :: proxy a -> [(Text,Natural)]+instance VersionTagsVal '[] where+	versionTagsVal _ = []+instance+ ( KnownSymbol s+ , KnownNat n+ , VersionTagsVal t+ ) => VersionTagsVal ('(s,n) ': t) where+	versionTagsVal _ =+		( Text.pack (symbolVal (Proxy @s))+		, fromIntegral (natVal (Proxy @n))+		) : versionTagsVal (Proxy :: Proxy t)

@@ -19,11 +19,11 @@ 	 [ testCase "WeakParams" $ 		reify weakFFC $ \(Proxy::Proxy c) -> 			List.take 10 (groupGenInverses @_ @c) @?=-				[groupGen^neg (fromNatural n) | n <- [0..9]]+				[groupGen^negate (fromNatural n) | n <- [0..9]] 	 , testCase "BeleniosParams" $ 		reify beleniosFFC $ \(Proxy::Proxy c) -> 			List.take 10 (groupGenInverses @_ @c) @?=-				[groupGen^neg (fromNatural n) | n <- [0..9]]+				[groupGen^negate (fromNatural n) | n <- [0..9]] 	 ]  , testGroup "encryptBallot" $ 	 [ hunitsEncryptBallot v weakFFC

@@ -10,7 +10,7 @@  hunit :: Reifies v Version => Proxy v -> TestTree hunit _v = testGroup "FFC"- [ testGroup "inv"+ [ testGroup "inverse" 	 [ hunitInv weakFFC 	 , hunitInv beleniosFFC 	 ]@@ -44,6 +44,6 @@ 	testGroup (Text.unpack $ cryptoName crypto) 	 [ testCase "groupGen" $ 			reifyCrypto crypto $ \(_c::Proxy c) ->-				inv (groupGen :: G crypto c) @?=+				inverse (groupGen :: G crypto c) @?= 					groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) 	 ]

@@ -107,7 +107,7 @@  encryptTallyResult ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Monad m => RandomGen r =>  PublicKey crypto c -> [[Natural]] -> StateT r m (EncryptedTally crypto v c, Natural) encryptTallyResult pubKey countByChoiceByQuest =

@@ -35,7 +35,7 @@  quickcheckElection ::  Reifies v Version => - GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto => JSON.ToJSON crypto => Show crypto =>  Proxy v -> Proxy c -> TestTree quickcheckElection (_v::Proxy v) (c::Proxy c) =@@ -53,11 +53,11 @@ instance Reifies c FFC => Arbitrary (F c) where 	arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one) -}-instance GroupParams crypto c => Arbitrary (G crypto c) where+instance CryptoParams crypto c => Arbitrary (G crypto c) where 	arbitrary = do 		m <- arbitrary 		return (groupGen ^ m)-instance GroupParams crypto c => Arbitrary (E crypto c) where+instance CryptoParams crypto c => Arbitrary (E crypto c) where 	arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one) instance Arbitrary UUID where 	arbitrary = do@@ -66,7 +66,7 @@ 			randomUUID instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  , Arbitrary (E crypto c)  ) => Arbitrary (Proof crypto v c) where 	arbitrary = do@@ -90,7 +90,7 @@ 		] instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  , Key crypto  , JSON.ToJSON crypto  ) => Arbitrary (Election crypto v c) where@@ -138,7 +138,7 @@ 		] instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  , Key crypto  , JSON.ToJSON crypto  ) => Arbitrary (Election crypto v c :> [[Bool]]) where

@@ -22,7 +22,7 @@  testIndispensableTrusteePublicKey ::  Reifies v Version =>- GroupParams crypto c =>+ CryptoParams crypto c =>  Key crypto =>  Proxy v -> Proxy c -> TestTree testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) =@@ -38,7 +38,7 @@  instance  ( Reifies v Version- , GroupParams crypto c+ , CryptoParams crypto c  ) => Arbitrary (TrusteePublicKey crypto v c) where 	arbitrary = do 		trustee_PublicKey <- arbitrary