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