protocol: fix JSON error name
[majurity.git] / hjugement-protocol / tests / QuickCheck / Election.hs
index 5bd09dff37308986c5d5d18fa73d7e62cfcbc3ea..9b039edb40f8edb8e9a4a70ed590b0cea4625c6c 100644 (file)
@@ -24,20 +24,23 @@ maxArbitraryChoices = 5
 maxArbitraryQuestions :: Natural
 maxArbitraryQuestions = 2
 
-quickcheck :: TestTree
-quickcheck =
+quickcheck :: Reifies v Version => Proxy v -> TestTree
+quickcheck =
        testGroup "Election"
-        [ testGroup "verifyBallot" $
-                [ testElection weakFFC
-                , testElection beleniosFFC
+        [ testGroup "verifyBallot" $ 
+                [ reify weakFFC $ quickcheckElection v
+                , reify beleniosFFC $ quickcheckElection v
                 ]
         ]
 
-testElection :: FFC -> TestTree
-testElection ffc =
-       reify ffc $ \(Proxy::Proxy c) ->
-       testGroup (Text.unpack $ ffc_name ffc)
-        [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) ->
+quickcheckElection ::
+ Reifies v Version => 
+ CryptoParams crypto c =>
+ Key crypto => JSON.ToJSON crypto => Show crypto =>
+ Proxy v -> Proxy c -> TestTree
+quickcheckElection (_v::Proxy v) (c::Proxy c) =
+       testGroup (Text.unpack $ cryptoName (reflect c))
+        [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) ->
                isRight $ runExcept $
                        (`evalStateT` mkStdGen seed) $ do
                                -- ballotSecKey :: SecretKey c <- randomSecretKey
@@ -46,25 +49,31 @@ testElection ffc =
                                        lift $ throwE $ ErrorBallot_Wrong
         ]
 
+{-
 instance Reifies c FFC => Arbitrary (F c) where
        arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one)
-instance Reifies c FFC => Arbitrary (G c) where
+-}
+instance CryptoParams crypto c => Arbitrary (G crypto c) where
        arbitrary = do
                m <- arbitrary
                return (groupGen ^ m)
-instance Reifies c FFC => Arbitrary (E c) where
-       arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one)
+instance CryptoParams crypto c => Arbitrary (E crypto c) where
+       arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one)
 instance Arbitrary UUID where
        arbitrary = do
                seed <- arbitrary
                (`evalStateT` mkStdGen seed) $
                        randomUUID
-instance Reifies c FFC => Arbitrary (Proof c) where
+instance
+ ( Reifies v Version
+ , CryptoParams crypto c
+ , Arbitrary (E crypto c)
+ ) => Arbitrary (Proof crypto v c) where
        arbitrary = do
                proof_challenge <- arbitrary
                proof_response  <- arbitrary
                return Proof{..}
-instance Arbitrary Question where
+instance Reifies v Version => Arbitrary (Question v) where
        arbitrary = do
                let question_text = "question"
                choices :: Natural <- choose (1, maxArbitraryChoices)
@@ -79,29 +88,42 @@ instance Arbitrary Question where
                , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest
                , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest
                ]
-instance Reifies c FFC => Arbitrary (Election c) where
+instance
+ ( Reifies v Version
+ , CryptoParams crypto c
+ , Key crypto
+ , JSON.ToJSON crypto
+ ) => Arbitrary (Election crypto v c) where
        arbitrary = do
                let election_name = "election"
                let election_description = "description"
-               election_crypto <- arbitrary
+               let election_crypto = reflect (Proxy @c)
+               election_secret_key <- arbitrary
+               let election_public_key = publicKey election_secret_key
                election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary
                election_uuid <- arbitrary
-               let election_hash = hashJSON JSON.Null
-               return Election{..}
+               let elec = Election
+                        { election_hash    = hashElection elec
+                        , election_version = Just (reflect (Proxy @v))
+                        , ..
+                        }
+               return elec
        shrink elec =
                [ elec{election_questions}
                | election_questions <- shrink $ election_questions elec
                ]
+{-
 instance Reifies c FFC => Arbitrary (ElectionCrypto c) where
        arbitrary = do
                let electionCrypto_FFC_params = reflect (Proxy::Proxy c)
                electionCrypto_FFC_PublicKey <- arbitrary
                return ElectionCrypto_FFC{..}
+-}
 
 -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.
 data (:>) a b = a :> b
  deriving (Eq,Show)
-instance Arbitrary (Question :> [Bool]) where
+instance Reifies v Version => Arbitrary (Question v :> [Bool]) where
        arbitrary = do
                quest@Question{..} <- arbitrary
                votes <- do
@@ -114,7 +136,12 @@ instance Arbitrary (Question :> [Bool]) where
                [ q :> shrinkVotes q votes
                | q <- shrink quest
                ]
-instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where
+instance
+ ( Reifies v Version
+ , CryptoParams crypto c
+ , Key crypto
+ , JSON.ToJSON crypto
+ ) => Arbitrary (Election crypto v c :> [[Bool]]) where
        arbitrary = do
                elec@Election{..} <- arbitrary
                votes <- forM election_questions $ \Question{..} -> do
@@ -124,7 +151,7 @@ instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where
                        return $ boolsOfCombin numChoices numTrue rank
                return (elec :> votes)
        shrink (elec :> votes) =
-               [ e :> List.zipWith shrinkVotes (election_questions e) votes
+               [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes
                | e <- shrink elec
                ]
 
@@ -146,7 +173,7 @@ boolsOfCombin nBits nTrue rank
 -- | @('shrinkVotes' quest votes)@
 -- returns a reduced version of the given @votes@
 -- to fit the requirement of the given @quest@.
-shrinkVotes :: Question -> [Bool] -> [Bool]
+shrinkVotes :: Reifies v Version => Question v -> [Bool] -> [Bool]
 shrinkVotes Question{..} votes =
        (\(nTrue, b) -> nTrue <= nat question_maxi && b)
         <$> List.zip (countTrue votes) votes
@@ -156,4 +183,3 @@ shrinkVotes Question{..} votes =
                where
                inc [] = [zero]
                inc (n:ns) = (n+one):n:ns
-