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