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