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