{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Voting.Protocol.Cryptography where
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), join, replicateM)
import Control.Monad.Trans.Except (ExceptT(..), throwE)
import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=))
import Data.Bits
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
import Prelude (Bounded(..), fromIntegral)
import System.Random (RandomGen)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State.Strict as S
import qualified Crypto.Hash as Crypto
import qualified Data.Aeson as JSON
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLB
import qualified System.Random as Random
import Voting.Protocol.Utils
import Voting.Protocol.Arithmetic
import Voting.Protocol.Version
type PublicKey = G
type SecretKey = E
newtype Hash crypto c = Hash (E crypto c)
deriving newtype (Eq,Ord,Show,NFData)
hash :: CryptoParams crypto c => BS.ByteString -> [G crypto c] -> E crypto c
hash bs gs = do
let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)
let h = Crypto.hashWith Crypto.SHA256 s
fromNatural $
decodeBigEndian $ ByteArray.convert h
decodeBigEndian :: BS.ByteString -> Natural
decodeBigEndian =
BS.foldl'
(\acc b -> acc`shiftL`8 + fromIntegral b)
(0::Natural)
newtype Base64SHA256 = Base64SHA256 Text
deriving (Eq,Ord,Show,Generic)
deriving anyclass (ToJSON,FromJSON)
deriving newtype NFData
base64SHA256 :: BS.ByteString -> Base64SHA256
base64SHA256 bs =
let h = Crypto.hashWith Crypto.SHA256 bs in
Base64SHA256 $
Text.takeWhile (/= '=') $
Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h
newtype HexSHA256 = HexSHA256 Text
deriving (Eq,Ord,Show,Generic)
deriving anyclass (ToJSON,FromJSON)
deriving newtype NFData
hexSHA256 :: BS.ByteString -> Text
hexSHA256 bs =
let h = Crypto.hashWith Crypto.SHA256 bs in
let n = decodeBigEndian $ ByteArray.convert h in
TL.toStrict $
TL.tail $ TLB.toLazyText $ TLB.hexadecimal $
setBit n 256
randomR ::
Monad m =>
Random.RandomGen r =>
Random.Random i =>
Ring i =>
i -> S.StateT r m i
randomR i = S.StateT $ return . Random.randomR (zero, i-one)
random ::
Monad m =>
Random.RandomGen r =>
Random.Random i =>
Bounded i =>
S.StateT r m i
random = S.StateT $ return . Random.random
data Encryption crypto v c = Encryption
{ encryption_nonce :: !(G crypto c)
, encryption_vault :: !(G crypto c)
} deriving (Generic)
deriving instance Eq (G crypto c) => Eq (Encryption crypto v c)
deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c)
deriving instance NFData (G crypto c) => NFData (Encryption crypto v c)
instance
( Reifies v Version
, CryptoParams crypto c
) => ToJSON (Encryption crypto v c) where
toJSON Encryption{..} =
JSON.object
[ "alpha" .= encryption_nonce
, "beta" .= encryption_vault
]
toEncoding Encryption{..} =
JSON.pairs
( "alpha" .= encryption_nonce
<> "beta" .= encryption_vault
)
instance
( Reifies v Version
, CryptoParams crypto c
) => FromJSON (Encryption crypto v c) where
parseJSON = JSON.withObject "Encryption" $ \o -> do
encryption_nonce <- o .: "alpha"
encryption_vault <- o .: "beta"
return Encryption{..}
instance CryptoParams crypto c => Additive (Encryption crypto v c) where
zero = Encryption one one
x+y = Encryption
(encryption_nonce x * encryption_nonce y)
(encryption_vault x * encryption_vault y)
type EncryptionNonce = E
encrypt ::
Reifies v Version =>
CryptoParams crypto c =>
Monad m => RandomGen r =>
PublicKey crypto c -> E crypto c ->
S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c)
encrypt pubKey clear = do
encNonce <- random
return $ (encNonce,)
Encryption
{ encryption_nonce = groupGen^encNonce
, encryption_vault = pubKey ^encNonce * groupGen^clear
}
data Proof crypto v c = Proof
{ proof_challenge :: !(Challenge crypto c)
, proof_response :: !(E crypto c)
} deriving (Eq,Show,NFData,Generic)
instance Reifies v Version => ToJSON (Proof crypto v c) where
toJSON Proof{..} =
JSON.object
[ "challenge" .= proof_challenge
, "response" .= proof_response
]
toEncoding Proof{..} =
JSON.pairs
( "challenge" .= proof_challenge
<> "response" .= proof_response
)
instance
( CryptoParams crypto c
, Reifies v Version
) => FromJSON (Proof crypto v c) where
parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do
proof_challenge <- o .: "challenge"
proof_response <- o .: "response"
return Proof{..}
newtype ZKP = ZKP BS.ByteString
type Challenge = E
type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c
prove ::
forall crypto v c list m r.
Reifies v Version =>
CryptoParams crypto c =>
Monad m => RandomGen r => Functor list =>
E crypto c ->
list (G crypto c) ->
Oracle list crypto c ->
S.StateT r m (Proof crypto v c)
prove sec commitmentBases oracle = do
nonce <- random
let commitments = (^ nonce) <$> commitmentBases
let proof_challenge = oracle commitments
return Proof
{ proof_challenge
, proof_response = nonce `op` (sec*proof_challenge)
}
where
op =
if reflect (Proxy @v) `hasVersionTag` versionTagQuicker
then (-)
else (+)
proveQuicker ::
Reifies v Version =>
CryptoParams crypto c =>
Monad m => RandomGen r => Functor list =>
E crypto c ->
list (G crypto c) ->
Oracle list crypto c ->
S.StateT r m (Proof crypto v c)
proveQuicker sec commitmentBases oracle = do
nonce <- random
let commitments = (^ nonce) <$> commitmentBases
let proof_challenge = oracle commitments
return Proof
{ proof_challenge
, proof_response = nonce - sec*proof_challenge
}
fakeProof ::
CryptoParams crypto c =>
Monad m => RandomGen r =>
S.StateT r m (Proof crypto v c)
fakeProof = do
proof_challenge <- random
proof_response <- random
return Proof{..}
type Commitment = G
commit ::
forall crypto v c.
Reifies v Version =>
CryptoParams crypto c =>
Proof crypto v c ->
G crypto c ->
G crypto c ->
Commitment crypto c
commit Proof{..} base basePowSec =
(base^proof_response) `op`
(basePowSec^proof_challenge)
where
op =
if reflect (Proxy @v) `hasVersionTag` versionTagQuicker
then (*)
else (/)
{-# INLINE commit #-}
commitQuicker ::
CryptoParams crypto c =>
Proof crypto v c ->
G crypto c ->
G crypto c ->
Commitment crypto c
commitQuicker Proof{..} base basePowSec =
base^proof_response *
basePowSec^proof_challenge
type Disjunction = G
booleanDisjunctions ::
forall crypto c.
CryptoParams crypto c =>
[Disjunction crypto c]
booleanDisjunctions = List.take 2 $ groupGenInverses @crypto
intervalDisjunctions ::
forall crypto c.
CryptoParams crypto c =>
Natural -> Natural -> [Disjunction crypto c]
intervalDisjunctions mini maxi =
List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
List.genericDrop (nat mini) $
groupGenInverses @crypto
newtype DisjProof crypto v c = DisjProof [Proof crypto v c]
deriving (Eq,Show,Generic)
deriving newtype (NFData)
deriving newtype instance Reifies v Version => ToJSON (DisjProof crypto v c)
deriving newtype instance (Reifies v Version, CryptoParams crypto c) => FromJSON (DisjProof crypto v c)
proveEncryption ::
Reifies v Version =>
CryptoParams crypto c =>
Monad m => RandomGen r =>
PublicKey crypto c -> ZKP ->
([Disjunction crypto c],[Disjunction crypto c]) ->
(EncryptionNonce crypto c, Encryption crypto v c) ->
S.StateT r m (DisjProof crypto v c)
proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof
nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
let fakeChallengeSum =
sum (proof_challenge <$> prevFakeProofs) +
sum (proof_challenge <$> nextFakeProofs)
let statement = encryptionStatement voterZKP enc
genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
let prevCommitments = validCommitments prevDisjs prevFakeProofs in
let nextCommitments = validCommitments nextDisjs nextFakeProofs in
let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
let challenge = hash statement commitments in
let genuineChallenge = challenge - fakeChallengeSum in
genuineChallenge
let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
return (DisjProof proofs)
verifyEncryption ::
Reifies v Version =>
CryptoParams crypto c =>
Monad m =>
PublicKey crypto c -> ZKP ->
[Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) ->
ExceptT ErrorVerifyEncryption m Bool
verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
Nothing ->
throwE $ ErrorVerifyEncryption_InvalidProofLength
(fromIntegral $ List.length proofs)
(fromIntegral $ List.length disjs)
Just commitments ->
return $ challengeSum ==
hash (encryptionStatement voterZKP enc) (join commitments)
where
challengeSum = sum (proof_challenge <$> proofs)
encryptionStatement ::
CryptoParams crypto c =>
ZKP -> Encryption crypto v c -> BS.ByteString
encryptionStatement (ZKP voterZKP) Encryption{..} =
"prove|"<>voterZKP<>"|"
<> bytesNat encryption_nonce<>","
<> bytesNat encryption_vault<>"|"
encryptionCommitments ::
Reifies v Version =>
CryptoParams crypto c =>
PublicKey crypto c -> Encryption crypto v c ->
Disjunction crypto c -> Proof crypto v c -> [G crypto c]
encryptionCommitments elecPubKey Encryption{..} disj proof =
[ commit proof groupGen encryption_nonce
, commit proof elecPubKey (encryption_vault*disj)
]
data ErrorVerifyEncryption
= ErrorVerifyEncryption_InvalidProofLength Natural Natural
deriving (Eq,Show)
data Signature crypto v c = Signature
{ signature_publicKey :: !(PublicKey crypto c)
, signature_proof :: !(Proof crypto v c)
} deriving (Generic)
deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c)
instance
( Reifies v Version
, CryptoParams crypto c
) => ToJSON (Signature crypto v c) where
toJSON (Signature pubKey Proof{..}) =
JSON.object
[ "public_key" .= pubKey
, "challenge" .= proof_challenge
, "response" .= proof_response
]
toEncoding (Signature pubKey Proof{..}) =
JSON.pairs
( "public_key" .= pubKey
<> "challenge" .= proof_challenge
<> "response" .= proof_response
)
instance
( Reifies v Version
, CryptoParams crypto c
) => FromJSON (Signature crypto v c) where
parseJSON = JSON.withObject "Signature" $ \o -> do
signature_publicKey <- o .: "public_key"
proof_challenge <- o .: "challenge"
proof_response <- o .: "response"
let signature_proof = Proof{..}
return Signature{..}