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 c crypto => Group crypto => Key crypto => JSON.ToJSON crypto => Show crypto =>
  38  Reifies v Version => Proxy v ->
  39  Proxy c -> TestTree
  40 quickcheckElection (_v::Proxy v) (c::Proxy c)
  41  | Dict <- groupDict 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
  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  ) => Arbitrary (Election crypto v c :> [[Bool]]) where
 158         arbitrary | Dict <- groupDict (Proxy @c) = do
 159                 elec@Election{..} <- arbitrary
 160                 votes <- forM election_questions $ \Question{..} -> do
 161                         let numChoices = List.length question_choices
 162                         numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
 163                         rank <- choose (0, nCk numChoices numTrue - 1)
 164                         return $ boolsOfCombin numChoices numTrue rank
 165                 return (elec :> votes)
 166         shrink | Dict <- groupDict (Proxy @c) = \(elec :> votes) ->
 167                 [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes
 168                 | e <- shrink elec
 169                 ]
 170
 171 -- | @('boolsOfCombin' nBits nTrue rank)@ returns the 'rank'-th sequence of 'nBits'-bits possible
 172 -- with 'nTrue' bits set at 'True' and @(nBits-nTrue)@ set at 'False'.
 173 -- @rank@ has to be in @[0 .. 'nCk' nBits nTrue '-' 1]@
 174 boolsOfCombin :: Int -> Int -> Int -> [Bool]
 175 boolsOfCombin nBits nTrue rank
 176  | rank < 0 = undefined
 177  | nTrue == 0 = List.replicate nBits False
 178  | otherwise = go 0 cs <> List.replicate (nBits-List.last cs) False
 179         where
 180         cs = combinOfRank nBits nTrue rank
 181         go _d [] = []
 182         go curr (next:ns) =
 183                 List.replicate (next-1-curr) False <> [True]
 184                  <> go next ns
 185
 186 -- | @('shrinkVotes' quest votes)@
 187 -- returns a reduced version of the given @votes@
 188 -- to fit the requirement of the given @quest@.
 189 shrinkVotes :: Reifies v Version => Question v -> [Bool] -> [Bool]
 190 shrinkVotes Question{..} votes =
 191         (\(nTrue, b) -> nTrue <= nat question_maxi && b)
 192          <$> List.zip (countTrue votes) votes
 193         where
 194         countTrue :: [Bool] -> [Natural]
 195         countTrue = List.foldl' (\ns b -> if b then inc ns else ns) []
 196                 where
 197                 inc [] = [zero]
 198                 inc (n:ns) = (n+one):n:ns