hjugement-protocol/src/Voting/Protocol/FFC.hs

   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
  13
  14 import Control.Arrow (first)
  15 import Control.DeepSeq (NFData)
  16 import Control.Monad (Monad(..), unless)
  17 import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.:?), (.=))
  18 import Data.Bool
  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(..), reify)
  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
  43
  44 import Voting.Protocol.Arithmetic
  45 import Voting.Protocol.Cryptography
  46 import Voting.Protocol.Credential
  47
  48 -- * Type 'FFC'
  49 -- | Mutiplicative subgroup of a Finite Prime Field.
  50 --
  51 -- NOTE: an 'FFC' term-value is brought into the context of many functions
  52 -- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect'
  53 -- that 'FFC' at the term-level (a surprising technique but a very useful one).
  54 -- Doing like this is simpler than working in a 'Monad' (like a 'Reader'),
  55 -- and enables that 'FFC' term to be used simply in instances' methods
  56 -- not supporting an inner 'Monad', like 'parseJSON', 'randomR', 'fromEnum' or 'arbitrary'.
  57 -- Aside from that, the sharing of 'FFC' amongst several types
  58 -- is encoded at the type-level by including @c@
  59 -- as a phantom type of 'F', 'G' and 'E'.
  60 data FFC = FFC
  61  {   ffc_name :: !Text
  62  ,   ffc_fieldCharac :: !Natural
  63      -- ^ The prime number characteristic of a Finite Prime Field.
  64      --
  65      -- ElGamal's hardness to decrypt requires a large prime number
  66      -- to form the multiplicative subgroup.
  67  ,   ffc_groupGen :: !Natural
  68      -- ^ A generator of the multiplicative subgroup of the Finite Prime Field.
  69      --
  70      -- NOTE: since 'ffc_fieldCharac' is prime,
  71      -- the multiplicative subgroup is cyclic,
  72      -- and there are phi('fieldCharac'-1) many choices for the generator of the group,
  73      -- where phi is the Euler totient function.
  74  ,   ffc_groupOrder :: !Natural
  75      -- ^ The order of the subgroup.
  76      --
  77      -- WARNING: 'ffc_groupOrder' MUST be a prime number dividing @('ffc_fieldCharac'-1)@
  78      -- to ensure that ElGamal is secure in terms of the DDH assumption.
  79  } deriving (Eq,Show,Generic,NFData)
  80 instance ToJSON FFC where
  81         toJSON FFC{..} =
  82                 JSON.object $
  83                  (if Text.null ffc_name then [] else ["name" .= ffc_name] ) <>
  84                  [ "p" .= show ffc_fieldCharac
  85                  , "g" .= show ffc_groupGen
  86                  , "q" .= show ffc_groupOrder
  87                  ]
  88         toEncoding FFC{..} =
  89                 JSON.pairs $
  90                         (if Text.null ffc_name then mempty else "name" .= ffc_name) <>
  91                         "p" .= show ffc_fieldCharac <>
  92                         "g" .= show ffc_groupGen <>
  93                         "q" .= show ffc_groupOrder
  94 instance FromJSON FFC where
  95         parseJSON = JSON.withObject "FFC" $ \o -> do
  96                 ffc_name <- fromMaybe "" <$> (o .:? "name")
  97                 p <- o .: "p"
  98                 g <- o .: "g"
  99                 q <- o .: "q"
 100                 -- TODO: check p is probable prime
 101                 -- TODO: check q is probable prime
 102                 ffc_fieldCharac <- case readEither (Text.unpack p) of
 103                  Left err -> JSON.typeMismatch ("FFC: fieldCharac: "<>err) (JSON.String p)
 104                  Right a -> return a
 105                 ffc_groupGen <- case readEither (Text.unpack g) of
 106                  Left err -> JSON.typeMismatch ("FFC: groupGen: "<>err) (JSON.String g)
 107                  Right a -> return a
 108                 ffc_groupOrder <- case readEither (Text.unpack q) of
 109                  Left err -> JSON.typeMismatch ("FFC: groupOrder: "<>err) (JSON.String q)
 110                  Right a -> return a
 111                 unless (nat ffc_groupGen < ffc_fieldCharac) $
 112                         JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o)
 113                 unless (ffc_groupOrder < ffc_fieldCharac) $
 114                         JSON.typeMismatch "FFC: groupOrder is not lower than fieldCharac" (JSON.Object o)
 115                 unless (nat ffc_groupGen > 1) $
 116                         JSON.typeMismatch "FFC: groupGen is not greater than 1" (JSON.Object o)
 117                 unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $
 118                         JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o)
 119                 return FFC{..}
 120 instance Reifies c FFC => CryptoParams FFC c where
 121         groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c)
 122         groupOrder c = ffc_groupOrder $ reflect c
 123 instance ReifyCrypto FFC where
 124         reifyCrypto = reify
 125 instance Key FFC where
 126         cryptoType _ = "FFC"
 127         cryptoName = ffc_name
 128         randomSecretKey = random
 129         credentialSecretKey (UUID uuid) (Credential cred) =
 130                 fromNatural $ decodeBigEndian $
 131                 Crypto.fastPBKDF2_SHA256
 132                  Crypto.Parameters
 133                  { Crypto.iterCounts   = 1000
 134                  , Crypto.outputLength = 32 -- bytes, ie. 256 bits
 135                  }
 136                  (Text.encodeUtf8 cred)
 137                  (Text.encodeUtf8 uuid)
 138         publicKey = (groupGen @FFC ^)
 139
 140 fieldCharac :: forall c. Reifies c FFC => Natural
 141 fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c)
 142
 143 -- ** Examples
 144 -- | Weak parameters for debugging purposes only.
 145 weakFFC :: FFC
 146 weakFFC = FFC
 147  { ffc_name        = "weakFFC"
 148  , ffc_fieldCharac = 263
 149  , ffc_groupGen    = 2
 150  , ffc_groupOrder  = 131
 151  }
 152
 153 -- | Parameters used in Belenios.
 154 -- A 2048-bit 'fieldCharac' of a Finite Prime Field,
 155 -- with a 256-bit 'groupOrder' for a multiplicative subgroup
 156 -- generated by 'groupGen'.
 157 beleniosFFC :: FFC
 158 beleniosFFC = FFC
 159  { ffc_name        = "beleniosFFC"
 160  , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
 161  , ffc_groupGen    =  2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627
 162  , ffc_groupOrder  = 78571733251071885079927659812671450121821421258408794611510081919805623223441
 163  }
 164
 165 -- | The type of the elements of a Finite Prime Field.
 166 --
 167 -- A field must satisfy the following properties:
 168 --
 169 -- * @(f, ('+'), 'zero')@ forms an abelian group,
 170 --   called the additive group of 'f'.
 171 --
 172 -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
 173 --   called the multiplicative group of 'f'.
 174 --
 175 -- * ('*') is associative:
 176 --   @(a'*'b)'*'c == a'*'(b'*'c)@ and
 177 --   @a'*'(b'*'c) == (a'*'b)'*'c@.
 178 --
 179 -- * ('*') and ('+') are both commutative:
 180 --   @a'*'b == b'*'a@ and
 181 --   @a'+'b == b'+'a@
 182 --
 183 -- * ('*') and ('+') are both left and right distributive:
 184 --   @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
 185 --   @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
 186 --
 187 -- The 'Natural' is always within @[0..'fieldCharac'-1]@.
 188 type instance FieldElement FFC = Natural
 189 deriving newtype instance Eq     (G FFC c)
 190 deriving newtype instance Ord    (G FFC c)
 191 deriving newtype instance NFData (G FFC c)
 192 deriving newtype instance Show   (G FFC c)
 193 instance Reifies c FFC => FromJSON (G FFC c) where
 194         parseJSON (JSON.String s)
 195          | Just (c0,_) <- Text.uncons s
 196          , c0 /= '0'
 197          , Text.all Char.isDigit s
 198          , Just x <- readMaybe (Text.unpack s)
 199          , x < fieldCharac @c
 200          , r <- G x
 201          , r ^ E (groupOrder @FFC (Proxy @c)) == one
 202          = return r
 203         parseJSON json = JSON.typeMismatch "GroupElement" json
 204 instance ToJSON (G FFC c) where
 205         toJSON (G x) = JSON.toJSON (show x)
 206 instance Reifies c FFC => FromNatural (G FFC c) where
 207         fromNatural i = G $ abs $ i `mod` fieldCharac @c
 208                 where
 209                 abs x | x < 0 = x + fieldCharac @c
 210                       | otherwise = x
 211 instance ToNatural (G FFC c) where
 212         nat = unG
 213 instance Reifies c FFC => Additive (G FFC c) where
 214         zero = G 0
 215         G x + G y = G $ (x + y) `mod` fieldCharac @c
 216 instance Reifies c FFC => Semiring (G FFC c) where
 217         one = G 1
 218         G x * G y = G $ (x * y) `mod` fieldCharac @c
 219 instance Reifies c FFC => Ring (G FFC c) where
 220         negate (G x)
 221          | x == 0 = zero
 222          | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
 223 instance Reifies c FFC => EuclideanRing (G FFC c) where
 224         -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
 225         inverse = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1))
 226 instance Reifies c FFC => Random.Random (G FFC c) where
 227         randomR (G lo, G hi) =
 228                 first (G . fromIntegral) .
 229                 Random.randomR
 230                  ( 0`max`toInteger lo
 231                  , toInteger hi`min`(toInteger (fieldCharac @c) - 1) )
 232         random =
 233                 first (G . fromIntegral) .
 234                 Random.randomR (0, toInteger (fieldCharac @c) - 1)