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