hjugement-protocol/tests/QuickCheck/Election.hs

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