hjugement-protocol/src/Voting/Protocol/Election.hs

   1 {-# LANGUAGE DeriveAnyClass #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE DerivingStrategies #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE Rank2Types #-} -- for readElection
   6 {-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances
   7 module Voting.Protocol.Election where
   8
   9 import Control.DeepSeq (NFData)
  10 import Control.Monad (Monad(..), mapM, zipWithM)
  11 import Control.Monad.Trans.Class (MonadTrans(..))
  12 import Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT)
  13 import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
  14 import Data.Bool
  15 import Data.Either (either)
  16 import Data.Eq (Eq(..))
  17 import Data.Foldable (foldMap, and)
  18 import Data.Function (($), (.), id, const)
  19 import Data.Functor ((<$>))
  20 import Data.Functor.Identity (Identity(..))
  21 import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe)
  22 import Data.Monoid (Monoid(..))
  23 import Data.Ord (Ord(..))
  24 import Data.Proxy (Proxy(..))
  25 import Data.Reflection (Reifies(..), reify)
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.String (String)
  28 import Data.Text (Text)
  29 import Data.Traversable (Traversable(..))
  30 import Data.Tuple (fst, snd)
  31 import GHC.Generics (Generic)
  32 import GHC.Natural (minusNaturalMaybe)
  33 import Numeric.Natural (Natural)
  34 import Prelude (fromIntegral)
  35 import System.IO (IO, FilePath)
  36 import System.Random (RandomGen)
  37 import Text.Show (Show(..))
  38 import qualified Control.Monad.Trans.State.Strict as S
  39 import qualified Data.Aeson as JSON
  40 import qualified Data.Aeson.Encoding as JSON
  41 import qualified Data.Aeson.Internal as JSON
  42 import qualified Data.Aeson.Parser.Internal as JSON
  43 import qualified Data.Aeson.Types as JSON
  44 import qualified Data.ByteString as BS
  45 import qualified Data.ByteString.Lazy as BSL
  46 import qualified Data.List as List
  47
  48 import Voting.Protocol.Utils
  49 import Voting.Protocol.Arithmetic
  50 import Voting.Protocol.Version
  51 import Voting.Protocol.Credential
  52 import Voting.Protocol.Cryptography
  53
  54 -- * Type 'Question'
  55 data Question v = Question
  56  { question_text    :: !Text
  57  , question_choices :: ![Text]
  58  , question_mini    :: !Natural
  59  , question_maxi    :: !Natural
  60  -- , question_blank :: Maybe Bool
  61  } deriving (Eq,Show,Generic,NFData)
  62 instance Reifies v Version => ToJSON (Question v) where
  63         toJSON Question{..} =
  64                 JSON.object
  65                  [ "question" .= question_text
  66                  , "answers"  .= question_choices
  67                  , "min"      .= question_mini
  68                  , "max"      .= question_maxi
  69                  ]
  70         toEncoding Question{..} =
  71                 JSON.pairs
  72                  (  "question" .= question_text
  73                  <> "answers"  .= question_choices
  74                  <> "min"      .= question_mini
  75                  <> "max"      .= question_maxi
  76                  )
  77 instance Reifies v Version => FromJSON (Question v) where
  78         parseJSON = JSON.withObject "Question" $ \o -> do
  79                 question_text    <- o .: "question"
  80                 question_choices <- o .: "answers"
  81                 question_mini    <- o .: "min"
  82                 question_maxi    <- o .: "max"
  83                 return Question{..}
  84
  85 -- * Type 'Answer'
  86 data Answer crypto v c = Answer
  87  { answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)]
  88    -- ^ Encrypted 'Opinion' for each 'question_choices'
  89    -- with a 'DisjProof' that they belong to [0,1].
  90  , answer_sumProof :: !(DisjProof crypto v c)
  91    -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
  92    -- is an element of @[mini..maxi]@.
  93  -- , answer_blankProof ::
  94  } deriving (Generic)
  95 deriving instance Eq (G crypto c) => Eq (Answer crypto v c)
  96 deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Answer crypto v c)
  97 deriving instance NFData (G crypto c) => NFData (Answer crypto v c)
  98 instance
  99  ( Reifies v Version
 100  , CryptoParams crypto c
 101  ) => ToJSON (Answer crypto v c) where
 102         toJSON Answer{..} =
 103                 let (answer_choices, answer_individual_proofs) =
 104                         List.unzip answer_opinions in
 105                 JSON.object
 106                  [ "choices"           .= answer_choices
 107                  , "individual_proofs" .= answer_individual_proofs
 108                  , "overall_proof"     .= answer_sumProof
 109                  ]
 110         toEncoding Answer{..} =
 111                 let (answer_choices, answer_individual_proofs) =
 112                         List.unzip answer_opinions in
 113                 JSON.pairs
 114                  (  "choices"           .= answer_choices
 115                  <> "individual_proofs" .= answer_individual_proofs
 116                  <> "overall_proof"     .= answer_sumProof
 117                  )
 118 instance
 119  ( Reifies v Version
 120  , CryptoParams crypto c
 121  ) => FromJSON (Answer crypto v c) where
 122         parseJSON = JSON.withObject "Answer" $ \o -> do
 123                 answer_choices <- o .: "choices"
 124                 answer_individual_proofs <- o .: "individual_proofs"
 125                 let answer_opinions = List.zip answer_choices answer_individual_proofs
 126                 answer_sumProof <- o .: "overall_proof"
 127                 return Answer{..}
 128
 129 -- | @('encryptAnswer' elecPubKey zkp quest opinions)@
 130 -- returns an 'Answer' validable by 'verifyAnswer',
 131 -- unless an 'ErrorAnswer' is returned.
 132 encryptAnswer ::
 133  Reifies v Version =>
 134  CryptoParams crypto c =>
 135  Monad m => RandomGen r =>
 136  PublicKey crypto c -> ZKP ->
 137  Question v -> [Bool] ->
 138  S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c)
 139 encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice
 140  | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
 141         lift $ throwE $
 142                 ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi
 143  | List.length opinions /= List.length question_choices =
 144         lift $ throwE $
 145                 ErrorAnswer_WrongNumberOfOpinions
 146                  (fromIntegral $ List.length opinions)
 147                  (fromIntegral $ List.length question_choices)
 148  | otherwise = do
 149         encryptions <- encrypt elecPubKey `mapM` opinions
 150         individualProofs <- zipWithM
 151          (\opinion -> proveEncryption elecPubKey zkp $
 152                 if opinion
 153                 then (List.init booleanDisjunctions,[])
 154                 else ([],List.tail booleanDisjunctions))
 155          opinionByChoice encryptions
 156         sumProof <- proveEncryption elecPubKey zkp
 157          (List.tail <$> List.genericSplitAt
 158                  (fromJust $ opinionsSum`minusNaturalMaybe`question_mini)
 159                  (intervalDisjunctions question_mini question_maxi))
 160          ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
 161          , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
 162          )
 163         return $ Answer
 164          { answer_opinions = List.zip
 165                  (snd <$> encryptions) -- NOTE: drop encNonce
 166                  individualProofs
 167          , answer_sumProof = sumProof
 168          }
 169  where
 170         opinionsSum = sum $ nat <$> opinions
 171         opinions = (\o -> if o then one else zero) <$> opinionByChoice
 172
 173 verifyAnswer ::
 174  Reifies v Version =>
 175  CryptoParams crypto c =>
 176  PublicKey crypto c -> ZKP ->
 177  Question v -> Answer crypto v c -> Bool
 178 verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..}
 179  | List.length question_choices /= List.length answer_opinions = False
 180  | otherwise = do
 181         either (const False) id $ runExcept $ do
 182                 validOpinions <-
 183                         verifyEncryption elecPubKey zkp booleanDisjunctions
 184                          `traverse` answer_opinions
 185                 validSum <- verifyEncryption elecPubKey zkp
 186                  (intervalDisjunctions question_mini question_maxi)
 187                  ( sum (fst <$> answer_opinions)
 188                  , answer_sumProof )
 189                 return (and validOpinions && validSum)
 190
 191 -- ** Type 'ErrorAnswer'
 192 -- | Error raised by 'encryptAnswer'.
 193 data ErrorAnswer
 194  =   ErrorAnswer_WrongNumberOfOpinions Natural Natural
 195      -- ^ When the number of opinions is different than
 196      -- the number of choices ('question_choices').
 197  |   ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
 198      -- ^ When the sum of opinions is not within the bounds
 199      -- of 'question_mini' and 'question_maxi'.
 200  deriving (Eq,Show,Generic,NFData)
 201
 202 -- ** Type 'Opinion'
 203 -- | Index of a 'Disjunction' within a list of them.
 204 -- It is encrypted as a 'GroupExponent' by 'encrypt'.
 205 type Opinion = E
 206
 207 -- * Type 'Election'
 208 data Election crypto v c = Election
 209  { election_name        :: !Text
 210  , election_description :: !Text
 211  , election_questions   :: ![Question v]
 212  , election_uuid        :: !UUID
 213  , election_hash        :: Base64SHA256
 214  , election_crypto      :: !crypto
 215  , election_version     :: !(Maybe Version)
 216  , election_public_key  :: !(PublicKey crypto c)
 217  } deriving (Generic)
 218 deriving instance (Eq crypto, Eq (G crypto c)) => Eq (Election crypto v c)
 219 deriving instance (Show crypto, Show (G crypto c)) => Show (Election crypto v c)
 220 deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c)
 221 instance
 222  ( Reifies v Version
 223  , CryptoParams crypto c
 224  , ToJSON crypto
 225  ) => ToJSON (Election crypto v c) where
 226         toJSON Election{..} =
 227                 JSON.object $
 228                  [ "name" .= election_name
 229                  , "description" .= election_description
 230                  , ("public_key", JSON.object
 231                          [ "group" .= election_crypto
 232                          , "y" .= election_public_key
 233                          ])
 234                  , "questions" .= election_questions
 235                  , "uuid" .= election_uuid
 236                  ] <>
 237                  maybe [] (\version -> [ "version" .= version ]) election_version
 238         toEncoding Election{..} =
 239                 JSON.pairs $
 240                  (  "name" .= election_name
 241                  <> "description" .= election_description
 242                  <> JSON.pair "public_key" (JSON.pairs $
 243                         "group" .= election_crypto
 244                         <> "y" .= election_public_key
 245                  )
 246                  <> "questions" .= election_questions
 247                  <> "uuid" .= election_uuid
 248                  ) <>
 249                  maybe mempty ("version" .=) election_version
 250
 251 hashElection ::
 252  Reifies v Version =>
 253  CryptoParams crypto c =>
 254  ToJSON crypto =>
 255  Election crypto v c -> Base64SHA256
 256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode
 257
 258 readElection ::
 259  forall crypto r.
 260  FromJSON crypto =>
 261  ReifyCrypto crypto =>
 262  FilePath ->
 263  (forall v c.
 264         Reifies v Version =>
 265         CryptoParams crypto c =>
 266         Election crypto v c -> r) ->
 267  ExceptT String IO r
 268 readElection filePath k = do
 269         fileData <- lift $ BS.readFile filePath
 270         ExceptT $ return $
 271                 jsonEitherFormatError $
 272                         JSON.eitherDecodeStrictWith JSON.jsonEOF
 273                          (JSON.iparse (parseElection fileData))
 274                          fileData
 275         where
 276         parseElection fileData = JSON.withObject "Election" $ \o -> do
 277                 election_version <- o .:? "version"
 278                 reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do
 279                         (election_crypto, elecPubKey) <-
 280                                 JSON.explicitParseField
 281                                  (JSON.withObject "public_key" $ \obj -> do
 282                                                 crypto <- obj .: "group"
 283                                                 pubKey :: JSON.Value <- obj .: "y"
 284                                                 return (crypto, pubKey)
 285                                  ) o "public_key"
 286                         reifyCrypto election_crypto $ \(_c::Proxy c) -> do
 287                                 election_name <- o .: "name"
 288                                 election_description <- o .: "description"
 289                                 election_questions <- o .: "questions" :: JSON.Parser [Question v]
 290                                 election_uuid <- o .: "uuid"
 291                                 election_public_key :: PublicKey crypto c <- parseJSON elecPubKey
 292                                 return $ k $ Election
 293                                  { election_questions  = election_questions
 294                                  , election_public_key = election_public_key
 295                                  , election_hash       = base64SHA256 fileData
 296                                  , ..
 297                                  }
 298
 299 -- * Type 'Ballot'
 300 data Ballot crypto v c = Ballot
 301  { ballot_answers       :: ![Answer crypto v c]
 302  , ballot_signature     :: !(Maybe (Signature crypto v c))
 303  , ballot_election_uuid :: !UUID
 304  , ballot_election_hash :: !Base64SHA256
 305  } deriving (Generic)
 306 deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c)
 307 instance
 308  ( Reifies v Version
 309  , CryptoParams crypto c
 310  , ToJSON (G crypto c)
 311  ) => ToJSON (Ballot crypto v c) where
 312         toJSON Ballot{..} =
 313                 JSON.object $
 314                  [ "answers"       .= ballot_answers
 315                  , "election_uuid" .= ballot_election_uuid
 316                  , "election_hash" .= ballot_election_hash
 317                  ] <>
 318                  maybe [] (\sig -> [ "signature" .= sig ]) ballot_signature
 319         toEncoding Ballot{..} =
 320                 JSON.pairs $
 321                  (  "answers"       .= ballot_answers
 322                  <> "election_uuid" .= ballot_election_uuid
 323                  <> "election_hash" .= ballot_election_hash
 324                  ) <>
 325                  maybe mempty ("signature" .=) ballot_signature
 326 instance
 327  ( Reifies v Version
 328  , CryptoParams crypto c
 329  ) => FromJSON (Ballot crypto v c) where
 330         parseJSON = JSON.withObject "Ballot" $ \o -> do
 331                 ballot_answers       <- o .: "answers"
 332                 ballot_signature     <- o .:? "signature"
 333                 ballot_election_uuid <- o .: "election_uuid"
 334                 ballot_election_hash <- o .: "election_hash"
 335                 return Ballot{..}
 336
 337 -- | @('encryptBallot' c ('Just' ballotSecKey) opinionsByQuest)@
 338 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
 339 -- where 'opinionsByQuest' is a list of 'Opinion's
 340 -- on each 'question_choices' of each 'election_questions'.
 341 encryptBallot ::
 342  Reifies v Version =>
 343  CryptoParams crypto c => Key crypto =>
 344  Monad m => RandomGen r =>
 345  Election crypto v c ->
 346  Maybe (SecretKey crypto c) -> [[Bool]] ->
 347  S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c)
 348 encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQuest
 349  | List.length election_questions /= List.length opinionsByQuest =
 350         lift $ throwE $
 351                 ErrorBallot_WrongNumberOfAnswers
 352                  (fromIntegral $ List.length opinionsByQuest)
 353                  (fromIntegral $ List.length election_questions)
 354  | otherwise = do
 355         let (voterKeys, voterZKP) =
 356                 case ballotSecKeyMay of
 357                  Nothing -> (Nothing, ZKP "")
 358                  Just ballotSecKey ->
 359                         ( Just (ballotSecKey, ballotPubKey)
 360                         , ZKP (bytesNat ballotPubKey) )
 361                         where ballotPubKey = publicKey ballotSecKey
 362         ballot_answers <-
 363                 S.mapStateT (withExceptT ErrorBallot_Answer) $
 364                         zipWithM (encryptAnswer election_public_key voterZKP)
 365                          election_questions opinionsByQuest
 366         ballot_signature <- case voterKeys of
 367          Nothing -> return Nothing
 368          Just (ballotSecKey, signature_publicKey) -> do
 369                 signature_proof <-
 370                         proveQuicker ballotSecKey (Identity groupGen) $
 371                          \(Identity commitment) ->
 372                                 hash @crypto
 373                                  -- NOTE: the order is unusual, the commitments are first
 374                                  -- then comes the statement. Best guess is that
 375                                  -- this is easier to code due to their respective types.
 376                                  (ballotCommitments @crypto voterZKP commitment)
 377                                  (ballotStatement @crypto ballot_answers)
 378                 return $ Just Signature{..}
 379         return Ballot
 380          { ballot_answers
 381          , ballot_election_hash = election_hash
 382          , ballot_election_uuid = election_uuid
 383          , ballot_signature
 384          }
 385
 386 verifyBallot ::
 387  Reifies v Version =>
 388  CryptoParams crypto c =>
 389  Election crypto v c ->
 390  Ballot crypto v c -> Bool
 391 verifyBallot (Election{..}::Election crypto v c) Ballot{..} =
 392         ballot_election_uuid == election_uuid &&
 393         ballot_election_hash == election_hash &&
 394         List.length election_questions == List.length ballot_answers &&
 395         let (isValidSign, zkpSign) =
 396                 case ballot_signature of
 397                  Nothing -> (True, ZKP "")
 398                  Just Signature{..} ->
 399                         let zkp = ZKP (bytesNat signature_publicKey) in
 400                         (, zkp) $
 401                                 proof_challenge signature_proof == hash
 402                                  (ballotCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey))
 403                                  (ballotStatement @crypto ballot_answers)
 404         in
 405         and $ isValidSign :
 406                 List.zipWith (verifyAnswer election_public_key zkpSign)
 407                  election_questions ballot_answers
 408
 409
 410 -- ** Type 'ErrorBallot'
 411 -- | Error raised by 'encryptBallot'.
 412 data ErrorBallot
 413  =   ErrorBallot_WrongNumberOfAnswers Natural Natural
 414      -- ^ When the number of answers
 415      -- is different than the number of questions.
 416  |   ErrorBallot_Answer ErrorAnswer
 417      -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
 418  |   ErrorBallot_Wrong
 419      -- ^ TODO: to be more precise.
 420  deriving (Eq,Show,Generic,NFData)
 421
 422 -- ** Hashing
 423
 424 -- | @('ballotStatement' ballot)@
 425 -- returns the encrypted material to be signed:
 426 -- all the 'encryption_nonce's and 'encryption_vault's of the given 'ballot_answers'.
 427 ballotStatement :: CryptoParams crypto c => [Answer crypto v c] -> [G crypto c]
 428 ballotStatement =
 429         foldMap $ \Answer{..} ->
 430                 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
 431                         [encryption_nonce, encryption_vault]
 432
 433 -- | @('ballotCommitments' voterZKP commitment)@
 434 ballotCommitments ::
 435  CryptoParams crypto c =>
 436  ToNatural (G crypto c) =>
 437  ZKP -> Commitment crypto c -> BS.ByteString
 438 ballotCommitments (ZKP voterZKP) commitment =
 439         "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
 440          <> bytesNat commitment<>"|"