hjugement-protocol/test/HUnit/Election.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE PatternSynonyms #-}
   5 module HUnit.Election where
   6
   7 -- import Control.Applicative (Applicative(..))
   8 import qualified Control.Monad.Trans.Except as Exn
   9 import qualified Control.Monad.Trans.State.Strict as S
  10 import qualified Data.List as List
  11 import qualified System.Random as Random
  12
  13 import Protocol.Arithmetic
  14 import Protocol.Credential
  15 import Protocol.Election
  16 import HUnit.Utils
  17
  18 -- * Type 'Params'
  19 class SubGroup q => Params q where
  20         paramsName :: String
  21 instance Params WeakParams where
  22         paramsName = "WeakParams"
  23 instance Params BeleniosParams where
  24         paramsName = "BeleniosParams"
  25
  26 hunit :: TestTree
  27 hunit = testGroup "Election"
  28  [ testGroup "groupGenInverses"
  29          [ testCase "WeakParams" $
  30                 List.take 10 (groupGenInverses @WeakParams) @?=
  31                         [groupGen^neg (fromNatural n) | n <- [0..9]]
  32          , testCase "BeleniosParams" $
  33                 List.take 10 (groupGenInverses @BeleniosParams) @?=
  34                         [groupGen^neg (fromNatural n) | n <- [0..9]]
  35          ]
  36  , testGroup "encryptBallot" $
  37          [ testsEncryptBallot @WeakParams
  38          , testsEncryptBallot @BeleniosParams
  39          ]
  40  ]
  41
  42 testsEncryptBallot :: forall q. Params q => TestTree
  43 testsEncryptBallot =
  44         testGroup (paramsName @q)
  45          [ testEncryptBallot @q 0
  46                  [Question "q1" ["a1","a2","a3"] zero one]
  47                  [[True, False, False]]
  48                  (Right True)
  49          , testEncryptBallot @q 0
  50                  [Question "q1" ["a1","a2","a3"] zero one]
  51                  [[False, False, False]]
  52                  (Right True)
  53          , testEncryptBallot @q 0
  54                  [Question "q1" ["a1","a2","a3"] zero one]
  55                  [[False, False, False]]
  56                  (Right True)
  57          , testEncryptBallot @q 0
  58                  [Question "q1" [] zero one]
  59                  []
  60                  (Left (ErrorBallot_WrongNumberOfAnswers 0 1))
  61          , testEncryptBallot @q 0
  62                  [Question "q1" ["a1","a2"] one one]
  63                  [[True]]
  64                  (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2)))
  65          , testEncryptBallot @q 0
  66                  [Question "q1" ["a1","a2","a3"] zero one]
  67                  [[True, True, False]]
  68                  (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1)))
  69          , testEncryptBallot @q 0
  70                  [Question "q1" ["a1","a2","a3"] one one]
  71                  [[False, False, False]]
  72                  (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1)))
  73          , testEncryptBallot @q 0
  74                  [Question "q1" ["a1","a2"] one one]
  75                  [[False, False, True]]
  76                  (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2)))
  77          , testEncryptBallot @q 0
  78                  [ Question "q1" ["a11","a12","a13"] zero (one+one)
  79                  , Question "q2" ["a21","a22","a23"] one one
  80                  ]
  81                  [ [True, False, True]
  82                  , [False, True, False] ]
  83                  (Right True)
  84          ]
  85
  86 testEncryptBallot ::
  87  forall q. SubGroup q =>
  88  Int -> [Question q] -> [[Bool]] ->
  89  Either ErrorBallot Bool ->
  90  TestTree
  91 testEncryptBallot seed quests opins exp =
  92         let verify =
  93                 Exn.runExcept $
  94                 (`S.evalStateT` Random.mkStdGen seed) $ do
  95                         uuid <- randomUUID
  96                         cred <- randomCredential
  97                         let secKey = secretKey @q uuid cred
  98                         let pubKey = publicKey secKey
  99                         let elec = Election
 100                                  { election_name        = "election"
 101                                  , election_description = "description"
 102                                  , election_publicKey   = pubKey
 103                                  , election_questions   = quests
 104                                  , election_uuid        = uuid
 105                                  , election_hash        = Hash ""
 106                                  }
 107                         verifyBallot elec
 108                          <$> encryptBallot elec (Just secKey) opins
 109         in
 110         testCase (show opins) $
 111                 verify @?= exp