+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Finite Field Cryptography (FFC)
-- is a method of implementing discrete logarithm cryptography
-- using finite field mathematics.
-module Voting.Protocol.FFC
- ( module Voting.Protocol.FFC
- , Natural
- , Random.RandomGen
- , Reifies(..), reify
- , Proxy(..)
- ) where
+module Voting.Protocol.FFC where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), unless)
-import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
-import Data.Bits
+import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.:?), (.=))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable, foldl')
-import Data.Function (($), (.), id)
+import Data.Function (($), (.))
import Data.Functor ((<$>))
-import Data.Int (Int)
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
+import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..), reify)
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 (Integer, Integral(..), fromIntegral, Enum(..))
+import Prelude (Integral(..), fromIntegral)
import Text.Read (readMaybe, readEither)
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.State.Strict as S
-import qualified Crypto.Hash as Crypto
+import qualified Crypto.KDF.PBKDF2 as Crypto
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
-import qualified Data.ByteArray as ByteArray
-import qualified Data.ByteString as BS
import qualified Data.Char as Char
-import qualified Data.List as List
import qualified Data.Text as Text
-import qualified Prelude as Num
+import qualified Data.Text.Encoding as Text
import qualified System.Random as Random
+import Voting.Protocol.Arithmetic
+import Voting.Protocol.Cryptography
+import Voting.Protocol.Credential
+
-- * Type 'FFC'
--- | Mutiplicative Sub-Group of a Finite Prime Field.
+-- | Mutiplicative subgroup of a Finite Prime Field.
--
-- NOTE: an 'FFC' term-value is brought into the context of many functions
-- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect'
-- is encoded at the type-level by including @c@
-- as a phantom type of 'F', 'G' and 'E'.
data FFC = FFC
- { ffc_name :: Text
+ { ffc_name :: !Text
, ffc_fieldCharac :: !Natural
-- ^ The prime number characteristic of a Finite Prime Field.
--
-- ElGamal's hardness to decrypt requires a large prime number
- -- to form the 'Multiplicative' subgroup.
+ -- to form the multiplicative subgroup.
, ffc_groupGen :: !Natural
- -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field.
+ -- ^ A generator of the multiplicative subgroup of the Finite Prime Field.
--
-- NOTE: since 'ffc_fieldCharac' is prime,
- -- the 'Multiplicative' subgroup is cyclic,
+ -- the multiplicative subgroup is cyclic,
-- and there are phi('fieldCharac'-1) many choices for the generator of the group,
-- where phi is the Euler totient function.
, ffc_groupOrder :: !Natural
} deriving (Eq,Show,Generic,NFData)
instance ToJSON FFC where
toJSON FFC{..} =
- JSON.object
- [ "name" .= ffc_name
- , "p" .= show ffc_fieldCharac
- , "g" .= show ffc_groupGen
- , "q" .= show ffc_groupOrder
+ JSON.object $
+ (if Text.null ffc_name then [] else ["name" .= ffc_name] ) <>
+ [ "p" .= show ffc_fieldCharac
+ , "g" .= show ffc_groupGen
+ , "q" .= show ffc_groupOrder
]
toEncoding FFC{..} =
- JSON.pairs
- ( "name" .= ffc_name
- <> "p" .= show ffc_fieldCharac
- <> "g" .= show ffc_groupGen
- <> "q" .= show ffc_groupOrder
- )
+ JSON.pairs $
+ (if Text.null ffc_name then mempty else "name" .= ffc_name) <>
+ "p" .= show ffc_fieldCharac <>
+ "g" .= show ffc_groupGen <>
+ "q" .= show ffc_groupOrder
instance FromJSON FFC where
parseJSON = JSON.withObject "FFC" $ \o -> do
ffc_name <- fromMaybe "" <$> (o .:? "name")
unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $
JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o)
return FFC{..}
+instance Reifies c FFC => CryptoParams FFC c where
+ groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c)
+ groupOrder c = ffc_groupOrder $ reflect c
+instance ReifyCrypto FFC where
+ reifyCrypto = reify
+instance Key FFC where
+ cryptoType _ = "FFC"
+ cryptoName = ffc_name
+ randomSecretKey = random
+ credentialSecretKey (UUID uuid) (Credential cred) =
+ fromNatural $ decodeBigEndian $
+ Crypto.fastPBKDF2_SHA256
+ Crypto.Parameters
+ { Crypto.iterCounts = 1000
+ , Crypto.outputLength = 32 -- bytes, ie. 256 bits
+ }
+ (Text.encodeUtf8 cred)
+ (Text.encodeUtf8 uuid)
+ publicKey = (groupGen @FFC ^)
fieldCharac :: forall c. Reifies c FFC => Natural
-fieldCharac = ffc_fieldCharac (reflect (Proxy::Proxy c))
-
-groupGen :: forall c. Reifies c FFC => G c
-groupGen = G $ F $ ffc_groupGen (reflect (Proxy::Proxy c))
-
-groupOrder :: forall c. Reifies c FFC => Natural
-groupOrder = ffc_groupOrder (reflect (Proxy::Proxy c))
+fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c)
-- ** Examples
-- | Weak parameters for debugging purposes only.
-- | Parameters used in Belenios.
-- A 2048-bit 'fieldCharac' of a Finite Prime Field,
--- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup
+-- with a 256-bit 'groupOrder' for a multiplicative subgroup
-- generated by 'groupGen'.
beleniosFFC :: FFC
beleniosFFC = FFC
, ffc_groupOrder = 78571733251071885079927659812671450121821421258408794611510081919805623223441
}
--- * Type 'F'
-- | The type of the elements of a Finite Prime Field.
--
-- A field must satisfy the following properties:
--
-- * @(f, ('+'), 'zero')@ forms an abelian group,
--- called the 'Additive' group of 'f'.
+-- called the additive group of 'f'.
--
-- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
--- called the 'Multiplicative' group of 'f'.
+-- called the multiplicative group of 'f'.
--
-- * ('*') is associative:
-- @(a'*'b)'*'c == a'*'(b'*'c)@ and
-- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
--
-- The 'Natural' is always within @[0..'fieldCharac'-1]@.
-newtype F c = F { unF :: Natural }
- deriving (Eq,Ord,Show)
- deriving newtype NFData
-instance ToJSON (F c) where
- toJSON (F x) = JSON.toJSON (show x)
-instance Reifies c FFC => FromJSON (F c) where
+type instance FieldElement FFC = Natural
+deriving newtype instance Eq (G FFC c)
+deriving newtype instance Ord (G FFC c)
+deriving newtype instance NFData (G FFC c)
+deriving newtype instance Show (G FFC c)
+instance Reifies c FFC => FromJSON (G FFC c) where
parseJSON (JSON.String s)
| Just (c0,_) <- Text.uncons s
, c0 /= '0'
, Text.all Char.isDigit s
, Just x <- readMaybe (Text.unpack s)
, x < fieldCharac @c
- = return (F x)
- parseJSON json = JSON.typeMismatch "F" json
-instance Reifies c FFC => FromNatural (F c) where
- fromNatural i = F $ abs $ i `mod` fieldCharac @c
+ , r <- G x
+ , r ^ E (groupOrder @FFC (Proxy @c)) == one
+ = return r
+ parseJSON json = JSON.typeMismatch "GroupElement" json
+instance ToJSON (G FFC c) where
+ toJSON (G x) = JSON.toJSON (show x)
+instance Reifies c FFC => FromNatural (G FFC c) where
+ fromNatural i = G $ abs $ i `mod` fieldCharac @c
where
abs x | x < 0 = x + fieldCharac @c
| otherwise = x
-instance ToNatural (F c) where
- nat = unF
-instance Reifies c FFC => Additive (F c) where
- zero = F 0
- F x + F y = F $ (x + y) `mod` fieldCharac @c
-instance Reifies c FFC => Negable (F c) where
- neg (F x)
+instance ToNatural (G FFC c) where
+ nat = unG
+instance Reifies c FFC => Additive (G FFC c) where
+ zero = G 0
+ G x + G y = G $ (x + y) `mod` fieldCharac @c
+instance Reifies c FFC => Semiring (G FFC c) where
+ one = G 1
+ G x * G y = G $ (x * y) `mod` fieldCharac @c
+instance Reifies c FFC => Ring (G FFC c) where
+ negate (G x)
| x == 0 = zero
- | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
-instance Reifies c FFC => Multiplicative (F c) where
- one = F 1
- F x * F y = F $ (x * y) `mod` fieldCharac @c
-instance Reifies c FFC => Random.Random (F c) where
- randomR (F lo, F hi) =
- first (F . fromIntegral) .
+ | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
+instance Reifies c FFC => EuclideanRing (G FFC c) where
+ -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
+ inverse = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1))
+instance Reifies c FFC => Random.Random (G FFC c) where
+ randomR (G lo, G hi) =
+ first (G . fromIntegral) .
Random.randomR
( 0`max`toInteger lo
, toInteger hi`min`(toInteger (fieldCharac @c) - 1) )
random =
- first (F . fromIntegral) .
+ first (G . fromIntegral) .
Random.randomR (0, toInteger (fieldCharac @c) - 1)
-
--- ** Class 'Additive'
-class Additive a where
- zero :: a
- (+) :: a -> a -> a; infixl 6 +
- sum :: Foldable f => f a -> a
- sum = foldl' (+) zero
-instance Additive Natural where
- zero = 0
- (+) = (Num.+)
-instance Additive Integer where
- zero = 0
- (+) = (Num.+)
-instance Additive Int where
- zero = 0
- (+) = (Num.+)
-
--- *** Class 'Negable'
-class Additive a => Negable a where
- neg :: a -> a
- (-) :: a -> a -> a; infixl 6 -
- x-y = x + neg y
-instance Negable Integer where
- neg = Num.negate
-instance Negable Int where
- neg = Num.negate
-
--- ** Class 'Multiplicative'
-class Multiplicative a where
- one :: a
- (*) :: a -> a -> a; infixl 7 *
-instance Multiplicative Natural where
- one = 1
- (*) = (Num.*)
-instance Multiplicative Integer where
- one = 1
- (*) = (Num.*)
-instance Multiplicative Int where
- one = 1
- (*) = (Num.*)
-
--- ** Class 'Invertible'
-class Multiplicative a => Invertible a where
- inv :: a -> a
- (/) :: a -> a -> a; infixl 7 /
- x/y = x * inv y
-
--- * Type 'G'
--- | The type of the elements of a 'Multiplicative' subgroup of a Finite Prime Field.
-newtype G c = G { unG :: F c }
- deriving (Eq,Ord,Show)
- deriving newtype NFData
-instance ToJSON (G c) where
- toJSON (G x) = JSON.toJSON x
-instance Reifies c FFC => FromJSON (G c) where
- parseJSON (JSON.String s)
- | Just (c0,_) <- Text.uncons s
- , c0 /= '0'
- , Text.all Char.isDigit s
- , Just x <- readMaybe (Text.unpack s)
- , x < fieldCharac @c
- , r <- G (F x)
- , r ^ E (groupOrder @c) == one
- = return r
- parseJSON json = JSON.typeMismatch "G" json
-instance Reifies c FFC => FromNatural (G c) where
- fromNatural = G . fromNatural
-instance ToNatural (G c) where
- nat = unF . unG
-instance Reifies c FFC => Multiplicative (G c) where
- one = G $ F one
- G x * G y = G (x * y)
-instance Reifies c FFC => Invertible (G c) where
- -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
- inv = (^ E (fromJust $ groupOrder @c`minusNaturalMaybe`1))
-
--- | 'groupGenInverses' returns the infinite list
--- of 'inv'erse powers of 'groupGen':
--- @['groupGen' '^' 'neg' i | i <- [0..]]@,
--- but by computing each value from the previous one.
---
--- Used by 'intervalDisjunctions'.
-groupGenInverses :: forall c. Reifies c FFC => [G c]
-groupGenInverses = go one
- where
- invGen = inv $ groupGen @c
- go g = g : go (g * invGen)
-
-groupGenPowers :: forall c. Reifies c FFC => [G c]
-groupGenPowers = go one
- where go g = g : go (g * groupGen @c)
-
--- | @('hash' bs gs)@ returns as a number in 'E'
--- the SHA256 of the given 'BS.ByteString' 'bs'
--- prefixing the decimal representation of given subgroup elements 'gs',
--- with a comma (",") intercalated between them.
---
--- NOTE: to avoid any collision when the 'hash' function is used in different contexts,
--- a message 'gs' is actually prefixed by a 'bs' indicating the context.
---
--- Used by 'proveEncryption' and 'verifyEncryption',
--- where the 'bs' usually contains the 'statement' to be proven,
--- and the 'gs' contains the 'commitments'.
-hash :: Reifies c FFC => BS.ByteString -> [G c] -> E 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)@ interpret @bs@ as big-endian number.
-decodeBigEndian :: BS.ByteString -> Natural
-decodeBigEndian =
- BS.foldl'
- (\acc b -> acc`shiftL`8 + fromIntegral b)
- (0::Natural)
-
--- * Type 'E'
--- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field.
--- The value is always in @[0..'groupOrder'-1]@.
-newtype E c = E { unE :: Natural }
- deriving (Eq,Ord,Show)
- deriving newtype NFData
-instance ToJSON (E c) where
- toJSON (E x) = JSON.toJSON (show x)
-instance Reifies c FFC => FromJSON (E c) where
- parseJSON (JSON.String s)
- | Just (c0,_) <- Text.uncons s
- , c0 /= '0'
- , Text.all Char.isDigit s
- , Just x <- readMaybe (Text.unpack s)
- , x < groupOrder @c
- = return (E x)
- parseJSON json = JSON.typeMismatch "E" json
-
-instance Reifies c FFC => FromNatural (E c) where
- fromNatural i =
- E $ abs $ i `mod` groupOrder @c
- where
- abs x | x < 0 = x + groupOrder @c
- | otherwise = x
-instance ToNatural (E c) where
- nat = unE
-
-instance Reifies c FFC => Additive (E c) where
- zero = E zero
- E x + E y = E $ (x + y) `mod` groupOrder @c
-instance Reifies c FFC => Negable (E c) where
- neg (E x)
- | x == 0 = zero
- | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x
-instance Reifies c FFC => Multiplicative (E c) where
- one = E one
- E x * E y = E $ (x * y) `mod` groupOrder @c
-instance Reifies c FFC => Random.Random (E c) where
- randomR (E lo, E hi) =
- first (E . fromIntegral) .
- Random.randomR
- ( 0`max`toInteger lo
- , toInteger hi`min`(toInteger (groupOrder @c) - 1) )
- random =
- first (E . fromIntegral) .
- Random.randomR (0, toInteger (groupOrder @c) - 1)
-instance Reifies c FFC => Enum (E c) where
- toEnum = fromNatural . fromIntegral
- fromEnum = fromIntegral . nat
- enumFromTo lo hi = List.unfoldr
- (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
-
-infixr 8 ^
--- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
-(^) :: Reifies c FFC => G c -> E c -> G c
-(^) b (E e)
- | e == 0 = one
- | otherwise = t * (b*b) ^ E (e`shiftR`1)
- where
- t | testBit e 0 = b
- | otherwise = one
-
--- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
-randomR ::
- Monad m =>
- Random.RandomGen r =>
- Random.Random i =>
- Negable i =>
- Multiplicative i =>
- i -> S.StateT r m i
-randomR i = S.StateT $ return . Random.randomR (zero, i-one)
-
--- | @('random')@ returns a random integer
--- in the range determined by its type.
-random ::
- Monad m =>
- Random.RandomGen r =>
- Random.Random i =>
- Negable i =>
- Multiplicative i =>
- S.StateT r m i
-random = S.StateT $ return . Random.random
-
-instance Random.Random Natural where
- randomR (mini,maxi) =
- first (fromIntegral::Integer -> Natural) .
- Random.randomR (fromIntegral mini, fromIntegral maxi)
- random = first (fromIntegral::Integer -> Natural) . Random.random
-
--- * Conversions
-
--- ** Class 'FromNatural'
-class FromNatural a where
- fromNatural :: Natural -> a
-
--- ** Class 'ToNatural'
-class ToNatural a where
- nat :: a -> Natural
-instance ToNatural Natural where
- nat = id
-
--- | @('bytesNat' x)@ returns the serialization of 'x'.
-bytesNat :: ToNatural n => n -> BS.ByteString
-bytesNat = fromString . show . nat
sourcephile / git / majurity.git / blobdiff