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 :: Reifies v Version => Proxy v -> TestTree
  28 quickcheck v =
  29         testGroup "Election"
  30          [ testGroup "verifyBallot" $
  31                  [ quickcheckElection v weakFFC
  32                  , quickcheckElection v beleniosFFC
  33                  ]
  34          ]
  35
  36 quickcheckElection ::
  37  ReifyCrypto crypto =>
  38  Reifies v Version => Proxy v ->
  39  crypto -> TestTree
  40 quickcheckElection (_v::Proxy v) crypto =
  41         reifyCrypto crypto $ \(Proxy::Proxy c) ->
  42         testGroup (Text.unpack $ cryptoName crypto)
  43          [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) ->
  44                 isRight $ runExcept $
  45                         (`evalStateT` mkStdGen seed) $ do
  46                                 -- ballotSecKey :: SecretKey c <- randomSecretKey
  47                                 ballot <- encryptBallot elec Nothing votes
  48                                 unless (verifyBallot elec ballot) $
  49                                         lift $ throwE $ ErrorBallot_Wrong
  50          ]
  51
  52 instance Reifies c FFC => Arbitrary (F c) where
  53         arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one)
  54 instance
  55  ( Reifies c crypto
  56  , Group crypto
  57  , Multiplicative (FieldElement crypto c)
  58  ) => Arbitrary (G crypto c) where
  59         arbitrary = do
  60                 m <- arbitrary
  61                 return (groupGen ^ m)
  62 instance
  63  ( Reifies c crypto
  64  , Group crypto
  65  ) => Arbitrary (E crypto c) where
  66         arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one)
  67 instance Arbitrary UUID where
  68         arbitrary = do
  69                 seed <- arbitrary
  70                 (`evalStateT` mkStdGen seed) $
  71                         randomUUID
  72 instance
  73  ( Reifies v Version
  74  , Reifies c crypto
  75  , Arbitrary (E crypto c)
  76  ) => Arbitrary (Proof crypto v c) where
  77         arbitrary = do
  78                 proof_challenge <- arbitrary
  79                 proof_response  <- arbitrary
  80                 return Proof{..}
  81 instance Reifies v Version => Arbitrary (Question v) where
  82         arbitrary = do
  83                 let question_text = "question"
  84                 choices :: Natural <- choose (1, maxArbitraryChoices)
  85                 let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]]
  86                 question_mini <- choose (0, choices)
  87                 question_maxi <- choose (nat question_mini, choices)
  88                 return Question{..}
  89         shrink quest =
  90                 [ quest{question_choices, question_mini, question_maxi}
  91                 | question_choices <- shrinkList pure $ question_choices quest
  92                 , let nChoices = fromIntegral $ List.length question_choices
  93                 , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest
  94                 , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest
  95                 ]
  96 instance
  97  ( Reifies v Version
  98  , Reifies c crypto
  99  , Group crypto
 100  , Key crypto
 101  , Multiplicative (FieldElement crypto c)
 102  , JSON.ToJSON crypto
 103  , JSON.ToJSON (FieldElement crypto c)
 104  ) => Arbitrary (Election crypto v c) where
 105         arbitrary = do
 106                 let election_name = "election"
 107                 let election_description = "description"
 108                 let election_crypto = reflect (Proxy @c)
 109                 election_secret_key <- arbitrary
 110                 let election_public_key = publicKey election_secret_key
 111                 election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary
 112                 election_uuid <- arbitrary
 113                 let elec = Election
 114                          { election_hash    = hashElection elec
 115                          , election_version = Just (reflect (Proxy @v))
 116                          , ..
 117                          }
 118                 return elec
 119         shrink elec =
 120                 [ elec{election_questions}
 121                 | election_questions <- shrink $ election_questions elec
 122                 ]
 123 {-
 124 instance Reifies c FFC => Arbitrary (ElectionCrypto c) where
 125         arbitrary = do
 126                 let electionCrypto_FFC_params = reflect (Proxy::Proxy c)
 127                 electionCrypto_FFC_PublicKey <- arbitrary
 128                 return ElectionCrypto_FFC{..}
 129 -}
 130
 131 -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.
 132 data (:>) a b = a :> b
 133  deriving (Eq,Show)
 134 instance Reifies v Version => Arbitrary (Question v :> [Bool]) where
 135         arbitrary = do
 136                 quest@Question{..} <- arbitrary
 137                 votes <- do
 138                         let numChoices = List.length question_choices
 139                         numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
 140                         rank <- choose (0, nCk numChoices numTrue - 1)
 141                         return $ boolsOfCombin numChoices numTrue rank
 142                 return (quest :> votes)
 143         shrink (quest :> votes) =
 144                 [ q :> shrinkVotes q votes
 145                 | q <- shrink quest
 146                 ]
 147 instance
 148  ( Reifies v Version
 149  , Reifies c crypto
 150  , Group crypto
 151  , Key crypto
 152  , JSON.ToJSON crypto
 153  , JSON.ToJSON (FieldElement crypto c)
 154  , Multiplicative (FieldElement crypto c)
 155  ) => Arbitrary (Election crypto v c :> [[Bool]]) where
 156         arbitrary = do
 157                 elec@Election{..} <- arbitrary
 158                 votes <- forM election_questions $ \Question{..} -> do
 159                         let numChoices = List.length question_choices
 160                         numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
 161                         rank <- choose (0, nCk numChoices numTrue - 1)
 162                         return $ boolsOfCombin numChoices numTrue rank
 163                 return (elec :> votes)
 164         shrink (elec :> votes) =
 165                 [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes
 166                 | e <- shrink elec
 167                 ]
 168
 169 -- | @('boolsOfCombin' nBits nTrue rank)@ returns the 'rank'-th sequence of 'nBits'-bits possible
 170 -- with 'nTrue' bits set at 'True' and @(nBits-nTrue)@ set at 'False'.
 171 -- @rank@ has to be in @[0 .. 'nCk' nBits nTrue '-' 1]@
 172 boolsOfCombin :: Int -> Int -> Int -> [Bool]
 173 boolsOfCombin nBits nTrue rank
 174  | rank < 0 = undefined
 175  | nTrue == 0 = List.replicate nBits False
 176  | otherwise = go 0 cs <> List.replicate (nBits-List.last cs) False
 177         where
 178         cs = combinOfRank nBits nTrue rank
 179         go _d [] = []
 180         go curr (next:ns) =
 181                 List.replicate (next-1-curr) False <> [True]
 182                  <> go next ns
 183
 184 -- | @('shrinkVotes' quest votes)@
 185 -- returns a reduced version of the given @votes@
 186 -- to fit the requirement of the given @quest@.
 187 shrinkVotes :: Reifies v Version => Question v -> [Bool] -> [Bool]
 188 shrinkVotes Question{..} votes =
 189         (\(nTrue, b) -> nTrue <= nat question_maxi && b)
 190          <$> List.zip (countTrue votes) votes
 191         where
 192         countTrue :: [Bool] -> [Natural]
 193         countTrue = List.foldl' (\ns b -> if b then inc ns else ns) []
 194                 where
 195                 inc [] = [zero]
 196                 inc (n:ns) = (n+one):n:ns