1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE DerivingStrategies #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 -- | Finite Field Cryptography (FFC)
8 -- is a method of implementing discrete logarithm cryptography
9 -- using finite field mathematics.
10 module Voting.Protocol.FFC
11 ( module Voting.Protocol.FFC
18 import Control.Arrow (first)
19 import Control.DeepSeq (NFData)
20 import Control.Monad (Monad(..), unless)
21 import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
24 import Data.Either (Either(..))
25 import Data.Eq (Eq(..))
26 import Data.Foldable (Foldable, foldl')
27 import Data.Function (($), (.), id)
28 import Data.Functor ((<$>))
30 import Data.Maybe (Maybe(..), fromMaybe, fromJust)
31 import Data.Ord (Ord(..))
32 import Data.Proxy (Proxy(..))
33 import Data.Reflection (Reifies(..), reify)
34 import Data.Semigroup (Semigroup(..))
35 import Data.String (IsString(..))
36 import Data.Text (Text)
37 import GHC.Generics (Generic)
38 import GHC.Natural (minusNaturalMaybe)
39 import Numeric.Natural (Natural)
40 import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
41 import Text.Read (readMaybe, readEither)
42 import Text.Show (Show(..))
43 import qualified Control.Monad.Trans.State.Strict as S
44 import qualified Crypto.Hash as Crypto
45 import qualified Data.Aeson as JSON
46 import qualified Data.Aeson.Types as JSON
47 import qualified Data.ByteArray as ByteArray
48 import qualified Data.ByteString as BS
49 import qualified Data.Char as Char
50 import qualified Data.List as List
51 import qualified Data.Text as Text
52 import qualified Prelude as Num
53 import qualified System.Random as Random
56 -- | Mutiplicative Sub-Group of a Finite Prime Field.
58 -- NOTE: an 'FFC' term-value is brought into the context of many functions
59 -- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect'
60 -- that 'FFC' at the term-level (a surprising technique but a very useful one).
61 -- Doing like this is simpler than working in a 'Monad' (like a 'Reader'),
62 -- and enables that 'FFC' term to be used simply in instances' methods
63 -- not supporting an inner 'Monad', like 'parseJSON', 'randomR', 'fromEnum' or 'arbitrary'.
64 -- Aside from that, the sharing of 'FFC' amongst several types
65 -- is encoded at the type-level by including @c@
66 -- as a phantom type of 'F', 'G' and 'E'.
69 , ffc_fieldCharac :: !Natural
70 -- ^ The prime number characteristic of a Finite Prime Field.
72 -- ElGamal's hardness to decrypt requires a large prime number
73 -- to form the 'Multiplicative' subgroup.
74 , ffc_groupGen :: !Natural
75 -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field.
77 -- NOTE: since 'ffc_fieldCharac' is prime,
78 -- the 'Multiplicative' subgroup is cyclic,
79 -- and there are phi('fieldCharac'-1) many choices for the generator of the group,
80 -- where phi is the Euler totient function.
81 , ffc_groupOrder :: !Natural
82 -- ^ The order of the subgroup.
84 -- WARNING: 'ffc_groupOrder' MUST be a prime number dividing @('ffc_fieldCharac'-1)@
85 -- to ensure that ElGamal is secure in terms of the DDH assumption.
86 } deriving (Eq,Show,Generic,NFData)
87 instance ToJSON FFC where
91 , "p" .= show ffc_fieldCharac
92 , "g" .= show ffc_groupGen
93 , "q" .= show ffc_groupOrder
98 <> "p" .= show ffc_fieldCharac
99 <> "g" .= show ffc_groupGen
100 <> "q" .= show ffc_groupOrder
102 instance FromJSON FFC where
103 parseJSON = JSON.withObject "FFC" $ \o -> do
104 ffc_name <- fromMaybe "" <$> (o .:? "name")
108 -- TODO: check p is probable prime
109 -- TODO: check q is probable prime
110 ffc_fieldCharac <- case readEither (Text.unpack p) of
111 Left err -> JSON.typeMismatch ("FFC: fieldCharac: "<>err) (JSON.String p)
113 ffc_groupGen <- case readEither (Text.unpack g) of
114 Left err -> JSON.typeMismatch ("FFC: groupGen: "<>err) (JSON.String g)
116 ffc_groupOrder <- case readEither (Text.unpack q) of
117 Left err -> JSON.typeMismatch ("FFC: groupOrder: "<>err) (JSON.String q)
119 unless (nat ffc_groupGen < ffc_fieldCharac) $
120 JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o)
121 unless (ffc_groupOrder < ffc_fieldCharac) $
122 JSON.typeMismatch "FFC: groupOrder is not lower than fieldCharac" (JSON.Object o)
123 unless (nat ffc_groupGen > 1) $
124 JSON.typeMismatch "FFC: groupGen is not greater than 1" (JSON.Object o)
125 unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $
126 JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o)
129 fieldCharac :: forall c. Reifies c FFC => Natural
130 fieldCharac = ffc_fieldCharac (reflect (Proxy::Proxy c))
132 groupGen :: forall c. Reifies c FFC => G c
133 groupGen = G $ F $ ffc_groupGen (reflect (Proxy::Proxy c))
135 groupOrder :: forall c. Reifies c FFC => Natural
136 groupOrder = ffc_groupOrder (reflect (Proxy::Proxy c))
139 -- | Weak parameters for debugging purposes only.
142 { ffc_name = "weakFFC"
143 , ffc_fieldCharac = 263
145 , ffc_groupOrder = 131
148 -- | Parameters used in Belenios.
149 -- A 2048-bit 'fieldCharac' of a Finite Prime Field,
150 -- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup
151 -- generated by 'groupGen'.
154 { ffc_name = "beleniosFFC"
155 , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
156 , ffc_groupGen = 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627
157 , ffc_groupOrder = 78571733251071885079927659812671450121821421258408794611510081919805623223441
161 -- | The type of the elements of a Finite Prime Field.
163 -- A field must satisfy the following properties:
165 -- * @(f, ('+'), 'zero')@ forms an abelian group,
166 -- called the 'Additive' group of 'f'.
168 -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
169 -- called the 'Multiplicative' group of 'f'.
171 -- * ('*') is associative:
172 -- @(a'*'b)'*'c == a'*'(b'*'c)@ and
173 -- @a'*'(b'*'c) == (a'*'b)'*'c@.
175 -- * ('*') and ('+') are both commutative:
176 -- @a'*'b == b'*'a@ and
179 -- * ('*') and ('+') are both left and right distributive:
180 -- @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
181 -- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
183 -- The 'Natural' is always within @[0..'fieldCharac'-1]@.
184 newtype F c = F { unF :: Natural }
185 deriving (Eq,Ord,Show)
186 deriving newtype NFData
187 instance ToJSON (F c) where
188 toJSON (F x) = JSON.toJSON (show x)
189 instance Reifies c FFC => FromJSON (F c) where
190 parseJSON (JSON.String s)
191 | Just (c0,_) <- Text.uncons s
193 , Text.all Char.isDigit s
194 , Just x <- readMaybe (Text.unpack s)
197 parseJSON json = JSON.typeMismatch "F" json
198 instance Reifies c FFC => FromNatural (F c) where
199 fromNatural i = F $ abs $ i `mod` fieldCharac @c
201 abs x | x < 0 = x + fieldCharac @c
203 instance ToNatural (F c) where
205 instance Reifies c FFC => Additive (F c) where
207 F x + F y = F $ (x + y) `mod` fieldCharac @c
208 instance Reifies c FFC => Negable (F c) where
211 | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
212 instance Reifies c FFC => Multiplicative (F c) where
214 F x * F y = F $ (x * y) `mod` fieldCharac @c
215 instance Reifies c FFC => Random.Random (F c) where
216 randomR (F lo, F hi) =
217 first (F . fromIntegral) .
220 , toInteger hi`min`(toInteger (fieldCharac @c) - 1) )
222 first (F . fromIntegral) .
223 Random.randomR (0, toInteger (fieldCharac @c) - 1)
225 -- ** Class 'Additive'
226 class Additive a where
228 (+) :: a -> a -> a; infixl 6 +
229 sum :: Foldable f => f a -> a
230 sum = foldl' (+) zero
231 instance Additive Natural where
234 instance Additive Integer where
237 instance Additive Int where
241 -- *** Class 'Negable'
242 class Additive a => Negable a where
244 (-) :: a -> a -> a; infixl 6 -
246 instance Negable Integer where
248 instance Negable Int where
251 -- ** Class 'Multiplicative'
252 class Multiplicative a where
254 (*) :: a -> a -> a; infixl 7 *
255 instance Multiplicative Natural where
258 instance Multiplicative Integer where
261 instance Multiplicative Int where
265 -- ** Class 'Invertible'
266 class Multiplicative a => Invertible a where
268 (/) :: a -> a -> a; infixl 7 /
272 -- | The type of the elements of a 'Multiplicative' subgroup of a Finite Prime Field.
273 newtype G c = G { unG :: F c }
274 deriving (Eq,Ord,Show)
275 deriving newtype NFData
276 instance ToJSON (G c) where
277 toJSON (G x) = JSON.toJSON x
278 instance Reifies c FFC => FromJSON (G c) where
279 parseJSON (JSON.String s)
280 | Just (c0,_) <- Text.uncons s
282 , Text.all Char.isDigit s
283 , Just x <- readMaybe (Text.unpack s)
286 , r ^ E (groupOrder @c) == one
288 parseJSON json = JSON.typeMismatch "G" json
289 instance Reifies c FFC => FromNatural (G c) where
290 fromNatural = G . fromNatural
291 instance ToNatural (G c) where
293 instance Reifies c FFC => Multiplicative (G c) where
295 G x * G y = G (x * y)
296 instance Reifies c FFC => Invertible (G c) where
297 -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
298 inv = (^ E (fromJust $ groupOrder @c`minusNaturalMaybe`1))
300 -- | 'groupGenInverses' returns the infinite list
301 -- of 'inv'erse powers of 'groupGen':
302 -- @['groupGen' '^' 'neg' i | i <- [0..]]@,
303 -- but by computing each value from the previous one.
305 -- Used by 'intervalDisjunctions'.
306 groupGenInverses :: forall c. Reifies c FFC => [G c]
307 groupGenInverses = go one
309 invGen = inv $ groupGen @c
310 go g = g : go (g * invGen)
312 groupGenPowers :: forall c. Reifies c FFC => [G c]
313 groupGenPowers = go one
314 where go g = g : go (g * groupGen @c)
316 -- | @('hash' bs gs)@ returns as a number in 'E'
317 -- the SHA256 of the given 'BS.ByteString' 'bs'
318 -- prefixing the decimal representation of given subgroup elements 'gs',
319 -- with a comma (",") intercalated between them.
321 -- NOTE: to avoid any collision when the 'hash' function is used in different contexts,
322 -- a message 'gs' is actually prefixed by a 'bs' indicating the context.
324 -- Used by 'proveEncryption' and 'verifyEncryption',
325 -- where the 'bs' usually contains the 'statement' to be proven,
326 -- and the 'gs' contains the 'commitments'.
327 hash :: Reifies c FFC => BS.ByteString -> [G c] -> E c
329 let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)
330 let h = Crypto.hashWith Crypto.SHA256 s
332 decodeBigEndian $ ByteArray.convert h
334 -- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number.
335 decodeBigEndian :: BS.ByteString -> Natural
338 (\acc b -> acc`shiftL`8 + fromIntegral b)
342 -- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field.
343 -- The value is always in @[0..'groupOrder'-1]@.
344 newtype E c = E { unE :: Natural }
345 deriving (Eq,Ord,Show)
346 deriving newtype NFData
347 instance ToJSON (E c) where
348 toJSON (E x) = JSON.toJSON (show x)
349 instance Reifies c FFC => FromJSON (E c) where
350 parseJSON (JSON.String s)
351 | Just (c0,_) <- Text.uncons s
353 , Text.all Char.isDigit s
354 , Just x <- readMaybe (Text.unpack s)
357 parseJSON json = JSON.typeMismatch "E" json
359 instance Reifies c FFC => FromNatural (E c) where
361 E $ abs $ i `mod` groupOrder @c
363 abs x | x < 0 = x + groupOrder @c
365 instance ToNatural (E c) where
368 instance Reifies c FFC => Additive (E c) where
370 E x + E y = E $ (x + y) `mod` groupOrder @c
371 instance Reifies c FFC => Negable (E c) where
374 | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x
375 instance Reifies c FFC => Multiplicative (E c) where
377 E x * E y = E $ (x * y) `mod` groupOrder @c
378 instance Reifies c FFC => Random.Random (E c) where
379 randomR (E lo, E hi) =
380 first (E . fromIntegral) .
383 , toInteger hi`min`(toInteger (groupOrder @c) - 1) )
385 first (E . fromIntegral) .
386 Random.randomR (0, toInteger (groupOrder @c) - 1)
387 instance Reifies c FFC => Enum (E c) where
388 toEnum = fromNatural . fromIntegral
389 fromEnum = fromIntegral . nat
390 enumFromTo lo hi = List.unfoldr
391 (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
394 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
395 (^) :: Reifies c FFC => G c -> E c -> G c
398 | otherwise = t * (b*b) ^ E (e`shiftR`1)
403 -- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
406 Random.RandomGen r =>
411 randomR i = S.StateT $ return . Random.randomR (zero, i-one)
413 -- | @('random')@ returns a random integer
414 -- in the range determined by its type.
417 Random.RandomGen r =>
422 random = S.StateT $ return . Random.random
424 instance Random.Random Natural where
425 randomR (mini,maxi) =
426 first (fromIntegral::Integer -> Natural) .
427 Random.randomR (fromIntegral mini, fromIntegral maxi)
428 random = first (fromIntegral::Integer -> Natural) . Random.random
432 -- ** Class 'FromNatural'
433 class FromNatural a where
434 fromNatural :: Natural -> a
436 -- ** Class 'ToNatural'
437 class ToNatural a where
439 instance ToNatural Natural where
442 -- | @('bytesNat' x)@ returns the serialization of 'x'.
443 bytesNat :: ToNatural n => n -> BS.ByteString
444 bytesNat = fromString . show . nat