hjugement-protocol/tests/QuickCheck/Election.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# OPTIONS -fno-warn-orphans #-}
   3 module QuickCheck.Election where
   4
   5 import Test.Tasty.QuickCheck
   6 import qualified Data.List as List
   7 import qualified Data.Text as Text
   8 import Data.Eq (Eq(..))
   9 import Data.Int (Int)
  10 import Data.Ord (Ord(..))
  11 import Prelude (undefined)
  12
  13 import Voting.Protocol
  14
  15 import Utils
  16
  17 -- Hardcoded limits to avoid keep a reasonable testing time.
  18 maxArbitraryChoices :: Natural
  19 maxArbitraryChoices = 5
  20 maxArbitraryQuestions :: Natural
  21 maxArbitraryQuestions = 5
  22
  23 quickcheck :: TestTree
  24 quickcheck =
  25         testGroup "Election"
  26          [ testGroup "verifyBallot" $
  27                  [ testElection @WeakParams
  28                  , testElection @BeleniosParams
  29                  ]
  30          ]
  31
  32 testElection :: forall q. Params q => TestTree
  33 testElection  =
  34         testGroup (paramsName @q)
  35          [ testProperty "verifyBallot" $ \(seed, (elec::Election q) :> votes) ->
  36                 isRight $ runExcept $
  37                         (`evalStateT` mkStdGen seed) $ do
  38                                 -- ballotSecKey :: SecretKey q <- randomSecretKey
  39                                 ballot <- encryptBallot elec Nothing votes
  40                                 unless (verifyBallot elec ballot) $
  41                                         lift $ throwE $ ErrorBallot_Wrong
  42          ]
  43
  44 instance PrimeField p => Arbitrary (F p) where
  45         arbitrary = choose (zero, F (fieldCharac @p) - one)
  46 instance SubGroup q => Arbitrary (G q) where
  47         arbitrary = do
  48                 m <- arbitrary
  49                 return (groupGen ^ m)
  50 instance SubGroup q => Arbitrary (E q) where
  51         arbitrary = E <$> choose (zero, groupOrder @q - one)
  52 instance Arbitrary UUID where
  53         arbitrary = do
  54                 seed <- arbitrary
  55                 (`evalStateT` mkStdGen seed) $
  56                         randomUUID
  57 instance SubGroup q => Arbitrary (Proof q) where
  58         arbitrary = do
  59                 proof_challenge <- arbitrary
  60                 proof_response  <- arbitrary
  61                 return Proof{..}
  62 instance SubGroup q => Arbitrary (Question q) where
  63         arbitrary = do
  64                 let question_text = "question"
  65                 choices :: Natural <- choose (1, maxArbitraryChoices)
  66                 let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]]
  67                 question_mini <- fromNatural <$> choose (0, choices)
  68                 question_maxi <- fromNatural <$> choose (nat question_mini, choices)
  69                 return Question{..}
  70         shrink quest =
  71                 [ quest{question_choices, question_mini, question_maxi}
  72                 | question_choices <- shrinkList pure $ question_choices quest
  73                 , let nChoices = fromNatural $ fromIntegral $ List.length question_choices
  74                 , question_mini <- shrink $ min nChoices $ max zero $ question_mini quest
  75                 , question_maxi <- shrink $ min nChoices $ max question_mini $ question_maxi quest
  76                 ]
  77 instance SubGroup q => Arbitrary (Election q) where
  78         arbitrary = do
  79                 let election_name = "election"
  80                 let election_description = "description"
  81                 election_PublicKey <- arbitrary
  82                 election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary
  83                 election_uuid <- arbitrary
  84                 let election_hash = Hash ""
  85                 return Election{..}
  86         shrink elec =
  87                 [ elec{election_questions}
  88                 | election_questions <- shrink $ election_questions elec
  89                 ]
  90
  91 -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.
  92 data (:>) a b = a :> b
  93  deriving (Eq,Show)
  94 instance SubGroup q => Arbitrary (Question q :> [Bool]) where
  95         arbitrary = do
  96                 quest@Question{..} <- arbitrary
  97                 votes <- do
  98                         let numChoices = List.length question_choices
  99                         numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
 100                         rank <- choose (0, nCk numChoices numTrue - 1)
 101                         return $ boolsOfCombin numChoices numTrue rank
 102                 return (quest :> votes)
 103         shrink (quest :> votes) =
 104                 [ q :> shrinkVotes q votes
 105                 | q <- shrink quest
 106                 ]
 107 instance SubGroup q => Arbitrary (Election q :> [[Bool]]) where
 108         arbitrary = do
 109                 elec@Election{..} <- arbitrary
 110                 votes <- forM election_questions $ \Question{..} -> do
 111                         let numChoices = List.length question_choices
 112                         numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
 113                         rank <- choose (0, nCk numChoices numTrue - 1)
 114                         return $ boolsOfCombin numChoices numTrue rank
 115                 return (elec :> votes)
 116         shrink (elec :> votes) =
 117                 [ e :> List.zipWith shrinkVotes (election_questions e) votes
 118                 | e <- shrink elec
 119                 ]
 120
 121 -- | @('boolsOfCombin' nBits nTrue rank)@ returns the 'rank'-th sequence of 'nBits'-bits possible
 122 -- with 'nTrue' bits set at 'True' and @(nBits-nTrue)@ set at 'False'.
 123 -- @rank@ has to be in @[0 .. 'nCk' nBits nTrue '-' 1]@
 124 boolsOfCombin :: Int -> Int -> Int -> [Bool]
 125 boolsOfCombin nBits nTrue rank
 126  | rank < 0 = undefined
 127  | nTrue == 0 = List.replicate nBits False
 128  | otherwise = go 0 cs <> List.replicate (nBits-List.last cs) False
 129         where
 130         cs = combinOfRank nBits nTrue rank
 131         go _d [] = []
 132         go curr (next:ns) =
 133                 List.replicate (next-1-curr) False <> [True]
 134                  <> go next ns
 135
 136 -- | @('shrinkVotes' quest votes)@
 137 -- returns a reduced version of the given @votes@
 138 -- to fit the requirement of the given @quest@.
 139 shrinkVotes :: Question q -> [Bool] -> [Bool]
 140 shrinkVotes Question{..} votes =
 141         (\(nTrue, b) -> nTrue <= nat question_maxi && b)
 142          <$> List.zip (countTrue votes) votes
 143         where
 144         countTrue :: [Bool] -> [Natural]
 145         countTrue = List.foldl' (\ns b -> if b then inc ns else ns) []
 146                 where
 147                 inc [] = [zero]
 148                 inc (n:ns) = (n+one):n:ns
 149