1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DeriveAnyClass #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DerivingStrategies #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE InstanceSigs #-}
7 {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
9 -- | Finite Field Cryptography (FFC)
10 -- is a method of implementing discrete logarithm cryptography
11 -- using finite field mathematics.
12 module Voting.Protocol.FFC where
14 import Control.Arrow (first)
15 import Control.DeepSeq (NFData)
16 import Control.Monad (Monad(..), unless)
17 import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import Data.Function (($), (.))
22 import Data.Functor ((<$>))
23 import Data.Maybe (Maybe(..), fromMaybe, fromJust)
24 import Data.Monoid (Monoid(..))
25 import Data.Ord (Ord(..))
26 import Data.Proxy (Proxy(..))
27 import Data.Reflection (Reifies(..))
28 import Data.Semigroup (Semigroup(..))
29 import Data.Text (Text)
30 import GHC.Generics (Generic)
31 import GHC.Natural (minusNaturalMaybe)
32 import Numeric.Natural (Natural)
33 import Prelude (Integral(..), fromIntegral)
34 import Text.Read (readMaybe, readEither)
35 import Text.Show (Show(..))
36 import qualified Crypto.KDF.PBKDF2 as Crypto
37 import qualified Data.Aeson as JSON
38 import qualified Data.Aeson.Types as JSON
39 import qualified Data.Char as Char
40 import qualified Data.Text as Text
41 import qualified Data.Text.Encoding as Text
42 import qualified System.Random as Random
44 import Voting.Protocol.Arith
45 import Voting.Protocol.Credential
48 -- | Mutiplicative subgroup of a Finite Prime Field.
50 -- NOTE: an 'FFC' term-value is brought into the context of many functions
51 -- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect'
52 -- that 'FFC' at the term-level (a surprising technique but a very useful one).
53 -- Doing like this is simpler than working in a 'Monad' (like a 'Reader'),
54 -- and enables that 'FFC' term to be used simply in instances' methods
55 -- not supporting an inner 'Monad', like 'parseJSON', 'randomR', 'fromEnum' or 'arbitrary'.
56 -- Aside from that, the sharing of 'FFC' amongst several types
57 -- is encoded at the type-level by including @c@
58 -- as a phantom type of 'F', 'G' and 'E'.
61 , ffc_fieldCharac :: !Natural
62 -- ^ The prime number characteristic of a Finite Prime Field.
64 -- ElGamal's hardness to decrypt requires a large prime number
65 -- to form the 'Multiplicative' subgroup.
66 , ffc_groupGen :: !Natural
67 -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field.
69 -- NOTE: since 'ffc_fieldCharac' is prime,
70 -- the 'Multiplicative' subgroup is cyclic,
71 -- and there are phi('fieldCharac'-1) many choices for the generator of the group,
72 -- where phi is the Euler totient function.
73 , ffc_groupOrder :: !Natural
74 -- ^ The order of the subgroup.
76 -- WARNING: 'ffc_groupOrder' MUST be a prime number dividing @('ffc_fieldCharac'-1)@
77 -- to ensure that ElGamal is secure in terms of the DDH assumption.
78 } deriving (Eq,Show,Generic,NFData)
79 instance ToJSON FFC where
82 (if Text.null ffc_name then [] else ["name" .= ffc_name] ) <>
83 [ "p" .= show ffc_fieldCharac
84 , "g" .= show ffc_groupGen
85 , "q" .= show ffc_groupOrder
89 (if Text.null ffc_name then mempty else "name" .= ffc_name) <>
90 "p" .= show ffc_fieldCharac <>
91 "g" .= show ffc_groupGen <>
92 "q" .= show ffc_groupOrder
93 instance FromJSON FFC where
94 parseJSON = JSON.withObject "FFC" $ \o -> do
95 ffc_name <- fromMaybe "" <$> (o .:? "name")
99 -- TODO: check p is probable prime
100 -- TODO: check q is probable prime
101 ffc_fieldCharac <- case readEither (Text.unpack p) of
102 Left err -> JSON.typeMismatch ("FFC: fieldCharac: "<>err) (JSON.String p)
104 ffc_groupGen <- case readEither (Text.unpack g) of
105 Left err -> JSON.typeMismatch ("FFC: groupGen: "<>err) (JSON.String g)
107 ffc_groupOrder <- case readEither (Text.unpack q) of
108 Left err -> JSON.typeMismatch ("FFC: groupOrder: "<>err) (JSON.String q)
110 unless (nat ffc_groupGen < ffc_fieldCharac) $
111 JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o)
112 unless (ffc_groupOrder < ffc_fieldCharac) $
113 JSON.typeMismatch "FFC: groupOrder is not lower than fieldCharac" (JSON.Object o)
114 unless (nat ffc_groupGen > 1) $
115 JSON.typeMismatch "FFC: groupGen is not greater than 1" (JSON.Object o)
116 unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $
117 JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o)
119 instance Group FFC where
120 groupGen :: forall c. Reifies c FFC => G FFC c
121 groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c)
122 groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural
123 groupOrder c = ffc_groupOrder $ reflect c
124 -- groupDict Proxy = Dict
126 instance Key FFC where
128 cryptoName = ffc_name
129 randomSecretKey = random
130 credentialSecretKey (UUID uuid) (Credential cred) =
131 fromNatural $ decodeBigEndian $
132 Crypto.fastPBKDF2_SHA256
134 { Crypto.iterCounts = 1000
135 , Crypto.outputLength = 32 -- bytes, ie. 256 bits
137 (Text.encodeUtf8 cred)
138 (Text.encodeUtf8 uuid)
139 publicKey = (groupGen @FFC ^)
141 fieldCharac :: forall c. Reifies c FFC => Natural
142 fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c)
145 -- | Weak parameters for debugging purposes only.
148 { ffc_name = "weakFFC"
149 , ffc_fieldCharac = 263
151 , ffc_groupOrder = 131
154 -- | Parameters used in Belenios.
155 -- A 2048-bit 'fieldCharac' of a Finite Prime Field,
156 -- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup
157 -- generated by 'groupGen'.
160 { ffc_name = "beleniosFFC"
161 , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
162 , ffc_groupGen = 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627
163 , ffc_groupOrder = 78571733251071885079927659812671450121821421258408794611510081919805623223441
166 -- | The type of the elements of a Finite Prime Field.
168 -- A field must satisfy the following properties:
170 -- * @(f, ('+'), 'zero')@ forms an abelian group,
171 -- called the 'Additive' group of 'f'.
173 -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
174 -- called the 'Multiplicative' group of 'f'.
176 -- * ('*') is associative:
177 -- @(a'*'b)'*'c == a'*'(b'*'c)@ and
178 -- @a'*'(b'*'c) == (a'*'b)'*'c@.
180 -- * ('*') and ('+') are both commutative:
181 -- @a'*'b == b'*'a@ and
184 -- * ('*') and ('+') are both left and right distributive:
185 -- @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
186 -- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
188 -- The 'Natural' is always within @[0..'fieldCharac'-1]@.
189 type instance FieldElement FFC = Natural
190 deriving newtype instance Eq (G FFC c)
191 deriving newtype instance Ord (G FFC c)
192 deriving newtype instance NFData (G FFC c)
193 deriving newtype instance Show (G FFC c)
194 instance Reifies c FFC => FromJSON (G FFC c) where
195 parseJSON (JSON.String s)
196 | Just (c0,_) <- Text.uncons s
198 , Text.all Char.isDigit s
199 , Just x <- readMaybe (Text.unpack s)
202 , r ^ E (groupOrder @FFC (Proxy @c)) == one
204 parseJSON json = JSON.typeMismatch "GroupElement" json
205 instance ToJSON (G FFC c) where
206 toJSON (G x) = JSON.toJSON (show x)
207 instance Reifies c FFC => FromNatural (G FFC c) where
208 fromNatural i = G $ abs $ i `mod` fieldCharac @c
210 abs x | x < 0 = x + fieldCharac @c
212 instance ToNatural (G FFC c) where
214 instance Reifies c FFC => Additive (G FFC c) where
216 G x + G y = G $ (x + y) `mod` fieldCharac @c
217 instance Reifies c FFC => Negable (G FFC c) where
220 | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
221 instance Reifies c FFC => Multiplicative (G FFC c) where
223 G x * G y = G $ (x * y) `mod` fieldCharac @c
224 instance Reifies c FFC => Random.Random (G FFC c) where
225 randomR (G lo, G hi) =
226 first (G . fromIntegral) .
229 , toInteger hi`min`(toInteger (fieldCharac @c) - 1) )
231 first (G . fromIntegral) .
232 Random.randomR (0, toInteger (fieldCharac @c) - 1)
233 instance Reifies c FFC => Invertible (G FFC c) where
234 -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
235 inv = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1))