Election.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-} -- for readElection
{-# LANGUAGE UndecidableInstances #-} -- for Reifies 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.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.Functor (Functor, (<$>), (<$))
import Data.Functor.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..), reify)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd)
import GHC.Generics (Generic)
import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
import Prelude (fromIntegral)
import System.IO (IO, FilePath)
import System.Random (RandomGen)
import Text.Show (Show(..), showChar, showString)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Encoding as JSON
import qualified Data.Aeson.Internal as JSON
import qualified Data.Aeson.Parser.Internal as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.Read as Read

import Voting.Protocol.Utils
import Voting.Protocol.Arith
import Voting.Protocol.Credential
import Voting.Protocol.FFC (FFC)

-- * 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 (FieldElement crypto c) => Eq (Encryption crypto v c)
deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Encryption crypto v c)
deriving instance NFData (FieldElement crypto c) => NFData (Encryption crypto v c)
instance
 ( Reifies v Version
 , Reifies c crypto
 , ToJSON (FieldElement crypto c)
 ) => ToJSON (Encryption crypto v c) where
	toJSON Encryption{..} =
		JSON.object
		 [ "alpha" .= encryption_nonce
		 , "beta"  .= encryption_vault
		 ]
	toEncoding Encryption{..} =
		JSON.pairs
		 (  "alpha" .= encryption_nonce
		 <> "beta"  .= encryption_vault
		 )
instance
 ( Reifies v Version
 , Reifies c crypto
 , FromJSON (G crypto c)
 ) => FromJSON (Encryption crypto v c) where
	parseJSON = JSON.withObject "Encryption" $ \o -> do
		encryption_nonce <- o .: "alpha"
		encryption_vault <- o .: "beta"
		return Encryption{..}

-- | Additive homomorphism.
-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
instance
 ( Reifies c crypto
 , Multiplicative (FieldElement crypto c)
 ) => Additive (Encryption crypto v c) where
	zero = Encryption one one
	x+y = Encryption
	 (encryption_nonce x * encryption_nonce y)
	 (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 =>
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement 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 Group crypto => 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 (Reifies c crypto, Group crypto) => FromJSON (Proof crypto v c) where
	parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do
		proof_challenge <- o .: "challenge"
		proof_response  <- o .: "response"
		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 c crypto =>
 Reifies v Version =>
 Group crypto =>
 Multiplicative (FieldElement 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 c crypto =>
 Reifies v Version =>
 Group crypto =>
 Multiplicative (FieldElement 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 ::
 Reifies c crypto =>
 Group crypto =>
 Monad m => RandomGen r =>
 S.StateT r m (Proof crypto v c)
fakeProof = do
	proof_challenge <- random
	proof_response  <- random
	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 =>
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 Proof crypto v c ->
 G crypto c ->
 G crypto c ->
 Commitment crypto c
commit Proof{..} base basePowSec =
	(base^proof_response) `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 ::
 Reifies c crypto =>
 Multiplicative (FieldElement crypto c) =>
 Proof crypto v c ->
 G crypto c ->
 G crypto c ->
 Commitment crypto c
commitQuicker Proof{..} base basePowSec =
	base^proof_response *
	basePowSec^proof_challenge

-- * 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.
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 [Disjunction crypto c]
booleanDisjunctions = List.take 2 $ groupGenInverses @crypto

intervalDisjunctions ::
 forall crypto c.
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 Natural -> Natural -> [Disjunction crypto c]
intervalDisjunctions mini maxi =
	List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
	List.genericDrop (nat mini) $
	groupGenInverses @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)
{-
deriving instance Eq (GroupExponent crypto c) => Eq (DisjProof crypto v c)
deriving instance Show (GroupExponent crypto c) => Show (DisjProof crypto v c)
deriving newtype instance NFData (GroupExponent crypto c) => NFData (DisjProof crypto v c)
deriving newtype instance
 ( Reifies c crypto
 , ToJSON (GroupExponent crypto c)
 ) => ToJSON (DisjProof crypto v c)
deriving newtype instance
 ( Reifies c crypto
 , FromJSON (GroupExponent crypto c)
 ) => FromJSON (DisjProof crypto v c)
-}

-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
-- returns a 'DisjProof' that 'enc' 'encrypt's
-- 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 =>
 Reifies c crypto =>
 Group crypto =>
 ToNatural (FieldElement crypto c) =>
 Multiplicative (FieldElement 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 =>
 Reifies c crypto =>
 Group crypto =>
 ToNatural (FieldElement crypto c) =>
 Multiplicative (FieldElement crypto c) =>
 Monad m =>
 PublicKey crypto c -> ZKP ->
 [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) ->
 ExceptT ErrorVerifyEncryption m Bool
verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
	case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
	 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 ::
 Reifies c crypto =>
 ToNatural (FieldElement 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 =>
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 PublicKey crypto c -> Encryption crypto v c ->
 Disjunction crypto c -> Proof crypto v c -> [G crypto c]
encryptionCommitments elecPubKey Encryption{..} disj proof =
	[ commit proof groupGen encryption_nonce
	  -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
	  -- 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 'Question'
data Question v = Question
 { question_text    :: !Text
 , question_choices :: ![Text]
 , question_mini    :: !Natural
 , question_maxi    :: !Natural
 -- , question_blank :: Maybe Bool
 } deriving (Eq,Show,Generic,NFData)
instance Reifies v Version => ToJSON (Question v) where
	toJSON Question{..} =
		JSON.object
		 [ "question" .= question_text
		 , "answers"  .= question_choices
		 , "min"      .= question_mini
		 , "max"      .= question_maxi
		 ]
	toEncoding Question{..} =
		JSON.pairs
		 (  "question" .= question_text
		 <> "answers"  .= question_choices
		 <> "min"      .= question_mini
		 <> "max"      .= question_maxi
		 )
instance Reifies v Version => FromJSON (Question v) where
	parseJSON = JSON.withObject "Question" $ \o -> do
		question_text    <- o .: "question"
		question_choices <- o .: "answers"
		question_mini    <- o .: "min"
		question_maxi    <- o .: "max"
		return Question{..}

-- * Type 'Answer'
data Answer crypto v c = Answer
 { answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)]
   -- ^ Encrypted 'Opinion' for each 'question_choices'
   -- with a 'DisjProof' that they belong to [0,1].
 , answer_sumProof :: !(DisjProof crypto v c)
   -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
   -- is an element of @[mini..maxi]@.
 -- , answer_blankProof ::
 } deriving (Generic)
deriving instance Eq (FieldElement crypto c) => Eq (Answer crypto v c)
deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Answer crypto v c)
deriving instance NFData (FieldElement crypto c) => NFData (Answer crypto v c)
instance
 ( Reifies v Version
 , Reifies c crypto
 , ToJSON (FieldElement crypto c)
 , Group crypto
 ) => ToJSON (Answer crypto v c) where
	toJSON Answer{..} =
		let (answer_choices, answer_individual_proofs) =
			List.unzip answer_opinions in
		JSON.object
		 [ "choices"           .= answer_choices
		 , "individual_proofs" .= answer_individual_proofs
		 , "overall_proof"     .= answer_sumProof
		 ]
	toEncoding Answer{..} =
		let (answer_choices, answer_individual_proofs) =
			List.unzip answer_opinions in
		JSON.pairs
		 (  "choices"           .= answer_choices
		 <> "individual_proofs" .= answer_individual_proofs
		 <> "overall_proof"     .= answer_sumProof
		 )
instance
 ( Reifies v Version
 , Reifies c crypto
 , FromJSON (G crypto c)
 , Group crypto
 ) => FromJSON (Answer crypto v c) where
	parseJSON = JSON.withObject "Answer" $ \o -> do
		answer_choices <- o .: "choices"
		answer_individual_proofs <- o .: "individual_proofs"
		let answer_opinions = List.zip answer_choices answer_individual_proofs
		answer_sumProof <- o .: "overall_proof"
		return Answer{..}

-- | @('encryptAnswer' elecPubKey zkp quest opinions)@
-- returns an 'Answer' validable by 'verifyAnswer',
-- unless an 'ErrorAnswer' is returned.
encryptAnswer ::
 Reifies v Version =>
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 ToNatural (FieldElement crypto c) =>
 Monad m => RandomGen r =>
 PublicKey crypto c -> ZKP ->
 Question v -> [Bool] ->
 S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c)
encryptAnswer elecPubKey zkp Question{..} opinionByChoice
 | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
	lift $ throwE $
		ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi
 | List.length opinions /= List.length question_choices =
	lift $ throwE $
		ErrorAnswer_WrongNumberOfOpinions
		 (fromIntegral $ List.length opinions)
		 (fromIntegral $ List.length question_choices)
 | otherwise = do
	encryptions <- encrypt elecPubKey `mapM` opinions
	individualProofs <- zipWithM
	 (\opinion -> proveEncryption elecPubKey zkp $
		if opinion
		then (List.init booleanDisjunctions,[])
		else ([],List.tail booleanDisjunctions))
	 opinionByChoice encryptions
	sumProof <- proveEncryption elecPubKey zkp
	 (List.tail <$> List.genericSplitAt
		 (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
	 )
	return $ Answer
	 { answer_opinions = List.zip
		 (snd <$> encryptions) -- NOTE: drop encNonce
		 individualProofs
	 , answer_sumProof = sumProof
	 }
 where
	opinionsSum = sum $ nat <$> opinions
	opinions = (\o -> if o then one else zero) <$> opinionByChoice

verifyAnswer ::
 Reifies v Version =>
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 ToNatural (FieldElement crypto c) =>
 PublicKey crypto c -> ZKP ->
 Question v -> Answer crypto v c -> Bool
verifyAnswer elecPubKey zkp Question{..} Answer{..}
 | List.length question_choices /= List.length answer_opinions = False
 | otherwise = either (const False) id $ runExcept $ do
	validOpinions <-
		verifyEncryption elecPubKey zkp booleanDisjunctions
		 `traverse` answer_opinions
	validSum <- verifyEncryption elecPubKey zkp
	 (intervalDisjunctions question_mini question_maxi)
	 ( sum (fst <$> answer_opinions)
	 , answer_sumProof )
	return (and validOpinions && validSum)

-- ** Type 'ErrorAnswer'
-- | Error raised by 'encryptAnswer'.
data ErrorAnswer
 =   ErrorAnswer_WrongNumberOfOpinions Natural Natural
     -- ^ When the number of opinions is different than
     -- the number of choices ('question_choices').
 |   ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
     -- ^ When the sum of opinions is not within the bounds
     -- of 'question_mini' and 'question_maxi'.
 deriving (Eq,Show,Generic,NFData)

-- * Type 'Election'
data Election crypto v c = Election
 { election_name        :: !Text
 , election_description :: !Text
 , election_questions   :: ![Question v]
 , election_uuid        :: !UUID
 , election_hash        :: Base64SHA256
 , election_crypto      :: !crypto
 , election_version     :: !(Maybe Version)
 , election_public_key  :: !(PublicKey crypto c)
 } deriving (Generic)
deriving instance (Eq crypto, Eq (FieldElement crypto c)) => Eq (Election crypto v c)
deriving instance (Show crypto, Show (FieldElement crypto c)) => Show (Election crypto v c)
deriving instance (NFData crypto, NFData (FieldElement crypto c)) => NFData (Election crypto v c)
instance
 ( ToJSON crypto
 , ToJSON (FieldElement crypto c)
 , Reifies v Version
 , Reifies c crypto
 ) => ToJSON (Election crypto v c) where
	toJSON Election{..} =
		JSON.object $
		 [ "name" .= election_name
		 , "description" .= election_description
		 , ("public_key", JSON.object
			 [ "group" .= election_crypto
			 , "y" .= election_public_key
			 ])
		 , "questions" .= election_questions
		 , "uuid" .= election_uuid
		 ] <>
		 maybe [] (\version -> [ "version" .= version ]) election_version
	toEncoding Election{..} =
		JSON.pairs $
		 (  "name" .= election_name
		 <> "description" .= election_description
		 <> JSON.pair "public_key" (JSON.pairs $
			"group" .= election_crypto
			<> "y" .= election_public_key
		 )
		 <> "questions" .= election_questions
		 <> "uuid" .= election_uuid
		 ) <>
		 maybe mempty ("version" .=) election_version

readElection ::
 ReifyCrypto crypto =>
 FromJSON crypto =>
 FilePath ->
 (forall v c.
  Reifies v Version =>
  Reifies c crypto =>
  FieldElementConstraints crypto c =>
  Election crypto v c -> r) ->
 ExceptT String IO r
readElection filePath k = do
	fileData <- lift $ BS.readFile filePath
	ExceptT $ return $
		jsonEitherFormatError $
			JSON.eitherDecodeStrictWith JSON.jsonEOF
			 (JSON.iparse (parseElection fileData))
			 fileData
	where
	parseElection fileData = JSON.withObject "Election" $ \o -> do
		election_version <- o .:? "version"
		reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do
			(election_crypto, elecPubKey) <-
				JSON.explicitParseField
				 (JSON.withObject "public_key" $ \obj -> do
						crypto <- obj .: "group"
						pubKey :: JSON.Value <- obj .: "y"
						return (crypto, pubKey)
				 ) o "public_key"
			reifyCrypto election_crypto $ \(_c::Proxy c) -> do
				election_name <- o .: "name"
				election_description <- o .: "description"
				election_questions <- o .: "questions" :: JSON.Parser [Question v]
				election_uuid <- o .: "uuid"
				election_public_key :: PublicKey crypto c <- parseJSON elecPubKey
				return $ k $ Election
				 { election_questions  = election_questions
				 , election_public_key = election_public_key
				 , election_hash       = base64SHA256 fileData
				 , ..
				 }

hashElection ::
 ToJSON crypto =>
 Reifies c crypto =>
 Reifies v Version =>
 ToJSON (FieldElement crypto c) =>
 Election crypto v c -> Base64SHA256
hashElection = base64SHA256 . BSL.toStrict . JSON.encode

-- ** Class 'ReifyCrypto'
-- | @('reifyCrypto' crypto k)@ is like @('reify' crypto k)@
-- but gives to @(k)@ more constraints than just @('Reifies' c crypto)@,
-- which is used when defining classes on @(crypto)@
-- where @(c)@ (the type variable guarantying the same
-- @crypto@graphic parameters are used throughout)
-- is not yet in scope and thus where one cannot
-- add those constraints requiring to have @(c)@ in scope.
-- See for instance the 'QuickcheckElection' class, in the tests.
--
-- For convenience, the 'ReifyCrypto' class also implies the pervasive
-- constraint 'Group'.
class
 ( Group crypto
 , Key crypto
 , Show crypto
 , NFData crypto
 , JSON.ToJSON crypto
 , JSON.FromJSON crypto
 ) => ReifyCrypto crypto where
	reifyCrypto ::
	 crypto -> (forall c.
	  Reifies c crypto =>
	  FieldElementConstraints crypto c =>
	  Proxy c -> r) -> r
instance ReifyCrypto FFC where
	reifyCrypto = reify

-- ** Class 'FieldElementConstraints'
-- | List the 'Constraint's on the element of the field
-- when the @(crypto)@ has not been instantiated to a specific type yet.
-- It concerns only 'Constraint's whose method act on @(a)@,
-- not @(x c)@ (eg. 'Group').
type FieldElementConstraints crypto c =
 ( Multiplicative (FieldElement crypto c)
 , FromNatural    (FieldElement crypto c)
 , ToNatural      (FieldElement crypto c)
 , Eq             (FieldElement crypto c)
 , Ord            (FieldElement crypto c)
 , Show           (FieldElement crypto c)
 , NFData         (FieldElement crypto c)
 , FromJSON       (FieldElement crypto c)
 , ToJSON         (FieldElement crypto c)
 , FromJSON       (G crypto c)
 , ToJSON         (G crypto c)
 )

-- * Type 'Ballot'
data Ballot crypto v c = Ballot
 { ballot_answers       :: ![Answer crypto v c]
 , ballot_signature     :: !(Maybe (Signature crypto v c))
 , ballot_election_uuid :: !UUID
 , ballot_election_hash :: !Base64SHA256
 } deriving (Generic)
deriving instance (NFData (FieldElement crypto c), NFData crypto) => NFData (Ballot crypto v c)
instance
 ( Reifies v Version
 , Reifies c crypto
 , Group crypto
 , ToJSON (FieldElement crypto c)
 ) => ToJSON (Ballot crypto v c) where
	toJSON Ballot{..} =
		JSON.object $
		 [ "answers"       .= ballot_answers
		 , "election_uuid" .= ballot_election_uuid
		 , "election_hash" .= ballot_election_hash
		 ] <>
		 maybe [] (\sig -> [ "signature" .= sig ]) ballot_signature
	toEncoding Ballot{..} =
		JSON.pairs $
		 (  "answers"       .= ballot_answers
		 <> "election_uuid" .= ballot_election_uuid
		 <> "election_hash" .= ballot_election_hash
		 ) <>
		 maybe mempty ("signature" .=) ballot_signature
instance
 ( Reifies v Version
 , Reifies c crypto
 , Group crypto
 , FromJSON (G crypto c)
 ) => FromJSON (Ballot crypto v c) where
	parseJSON = JSON.withObject "Ballot" $ \o -> do
		ballot_answers       <- o .: "answers"
		ballot_signature     <- o .:? "signature"
		ballot_election_uuid <- o .: "election_uuid"
		ballot_election_hash <- o .: "election_hash"
		return Ballot{..}

-- | @('encryptBallot' c ('Just' ballotSecKey) opinionsByQuest)@
-- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
-- where 'opinionsByQuest' is a list of 'Opinion's
-- on each 'question_choices' of each 'election_questions'.
encryptBallot ::
 forall crypto m v c r.
 Reifies c crypto =>
 Reifies v Version =>
 Group crypto =>
 Key crypto =>
 Multiplicative (FieldElement crypto c) =>
 ToNatural (FieldElement crypto c) =>
 Monad m => RandomGen r =>
 Election crypto v c ->
 Maybe (SecretKey crypto c) -> [[Bool]] ->
 S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c)
encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
 | List.length election_questions /= List.length opinionsByQuest =
	lift $ throwE $
		ErrorBallot_WrongNumberOfAnswers
		 (fromIntegral $ List.length opinionsByQuest)
		 (fromIntegral $ List.length election_questions)
 | otherwise = do
	let (voterKeys, voterZKP) =
		case ballotSecKeyMay of
		 Nothing -> (Nothing, ZKP "")
		 Just ballotSecKey ->
			( Just (ballotSecKey, ballotPubKey)
			, ZKP (bytesNat ballotPubKey) )
			where ballotPubKey = publicKey ballotSecKey
	ballot_answers <-
		S.mapStateT (withExceptT ErrorBallot_Answer) $
			zipWithM (encryptAnswer election_public_key voterZKP)
			 election_questions opinionsByQuest
	ballot_signature <- case voterKeys of
	 Nothing -> return Nothing
	 Just (ballotSecKey, signature_publicKey) -> do
		signature_proof <-
			proveQuicker ballotSecKey (Identity groupGen) $
			 \(Identity commitment) ->
				hash @_ @crypto
				 -- NOTE: the order is unusual, the commitments are first
				 -- then comes the statement. Best guess is that
				 -- this is easier to code due to their respective types.
				 (signatureCommitments @_ @crypto voterZKP commitment)
				 (signatureStatement @_ @crypto ballot_answers)
		return $ Just Signature{..}
	return Ballot
	 { ballot_answers
	 , ballot_election_hash = election_hash
	 , ballot_election_uuid = election_uuid
	 , ballot_signature
	 }

verifyBallot ::
 forall crypto v c.
 Reifies v Version =>
 Reifies c crypto =>
 Group crypto =>
 Multiplicative (FieldElement crypto c) =>
 ToNatural (FieldElement crypto c) =>
 ToNatural (PublicKey crypto c) =>
 Election crypto v c ->
 Ballot crypto v c -> Bool
verifyBallot Election{..} Ballot{..} =
	ballot_election_uuid == election_uuid &&
	ballot_election_hash == election_hash &&
	List.length election_questions == List.length ballot_answers &&
	let (isValidSign, zkpSign) =
		case ballot_signature of
		 Nothing -> (True, ZKP "")
		 Just Signature{..} ->
			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)
	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 (FieldElement crypto c)
 ) => NFData (Signature crypto v c)
instance
 ( Reifies c crypto
 , Reifies v Version
 , ToJSON (FieldElement crypto c)
 ) => ToJSON (Signature crypto v c) where
	toJSON (Signature pubKey Proof{..}) =
		JSON.object
		 [ "public_key" .= pubKey
		 , "challenge"  .= proof_challenge
		 , "response"   .= proof_response
		 ]
	toEncoding (Signature pubKey Proof{..}) =
		JSON.pairs
		 (  "public_key" .= pubKey
		 <> "challenge"  .= proof_challenge
		 <> "response"   .= proof_response
		 )
instance
 ( Reifies c crypto
 , Reifies v Version
 , Group crypto
 , FromJSON (PublicKey crypto c)
 ) => FromJSON (Signature crypto v c) where
	parseJSON = JSON.withObject "Signature" $ \o -> do
		signature_publicKey <- o .: "public_key"
		proof_challenge     <- o .: "challenge"
		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 :: Reifies c crypto => Foldable f => f (Answer crypto v c) -> [G crypto c]
signatureStatement =
	foldMap $ \Answer{..} ->
		(`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
			[encryption_nonce, encryption_vault]

-- | @('signatureCommitments' voterZKP commitment)@
signatureCommitments ::
 Reifies c crypto =>
 ToNatural (FieldElement crypto c) =>
 ZKP -> Commitment crypto c -> BS.ByteString
signatureCommitments (ZKP voterZKP) commitment =
	"sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
	 <> bytesNat commitment<>"|"

-- ** Type 'ErrorBallot'
-- | Error raised by 'encryptBallot'.
data ErrorBallot
 =   ErrorBallot_WrongNumberOfAnswers Natural Natural
     -- ^ When the number of answers
     -- is different than the number of questions.
 |   ErrorBallot_Answer ErrorAnswer
     -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
 |   ErrorBallot_Wrong
     -- ^ TODO: to be more precise.
 deriving (Eq,Show,Generic,NFData)

-- * Type 'Version'
-- | Version of the Helios-C protocol.
data Version = Version
 { version_branch :: [Natural]
 , version_tags   :: [(Text, Natural)]
 } deriving (Eq,Ord,Generic,NFData)
instance IsString Version where
	fromString = fromJust . readVersion
instance Show Version where
	showsPrec _p Version{..} =
		List.foldr (.) id
		 (List.intersperse (showChar '.') $
			showsPrec 0 <$> version_branch) .
		List.foldr (.) id
		 ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
			if n > 0 then showsPrec 0 n else id)
		 <$> version_tags)
instance ToJSON Version where
	toJSON     = toJSON     . show
	toEncoding = toEncoding . show
instance FromJSON Version where
	parseJSON (JSON.String s)
	 | Just v <- readVersion (Text.unpack s)
	 = return v
	parseJSON json = JSON.typeMismatch "Version" json

hasVersionTag :: Version -> Text -> Bool
hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)

experimentalVersion :: Version
experimentalVersion = stableVersion
 {version_tags = [(versionTagQuicker,0)]}

stableVersion :: Version
stableVersion = "1.6"

versionTagQuicker :: Text
versionTagQuicker = "quicker"

readVersion :: String -> Maybe Version
readVersion = parseReadP $ do
	version_branch <- Read.sepBy1
	 (Read.read <$> Read.munch1 Char.isDigit)
	 (Read.char '.')
	version_tags <- Read.many $ (,)
		 <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
		 <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
	return Version{..}

parseReadP :: Read.ReadP a -> String -> Maybe a
parseReadP p s =
	let p' = Read.readP_to_S p in
	listToMaybe $ do
		(x, "") <- p' s
		return x