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(..))
  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.Arith
  45 import Voting.Protocol.Credential
  46
  47 -- * Type 'FFC'
  48 -- | Mutiplicative Sub-Group of a Finite Prime Field.
  49 --
  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'.
  59 data FFC = FFC
  60  {   ffc_name :: Text
  61  ,   ffc_fieldCharac :: !Natural
  62      -- ^ The prime number characteristic of a Finite Prime Field.
  63      --
  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.
  68      --
  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.
  75      --
  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
  80         toJSON FFC{..} =
  81                 JSON.object $
  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
  86                  ]
  87         toEncoding FFC{..} =
  88                 JSON.pairs $
  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")
  96                 p <- o .: "p"
  97                 g <- o .: "g"
  98                 q <- o .: "q"
  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)
 103                  Right a -> return a
 104                 ffc_groupGen <- case readEither (Text.unpack g) of
 105                  Left err -> JSON.typeMismatch ("FFC: groupGen: "<>err) (JSON.String g)
 106                  Right a -> return a
 107                 ffc_groupOrder <- case readEither (Text.unpack q) of
 108                  Left err -> JSON.typeMismatch ("FFC: groupOrder: "<>err) (JSON.String q)
 109                  Right a -> return a
 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)
 118                 return FFC{..}
 119 instance Group FFC where
 120         groupGen :: forall c. Reifies c FFC => G FFC c
 121         groupGen = G $ F $ ffc_groupGen $ reflect (Proxy::Proxy c)
 122         groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural
 123         groupOrder c = ffc_groupOrder $ reflect c
 124
 125 fieldCharac :: forall c. Reifies c FFC => Natural
 126 fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c)
 127
 128 -- ** Examples
 129 -- | Weak parameters for debugging purposes only.
 130 weakFFC :: FFC
 131 weakFFC = FFC
 132  { ffc_name        = "weakFFC"
 133  , ffc_fieldCharac = 263
 134  , ffc_groupGen    = 2
 135  , ffc_groupOrder  = 131
 136  }
 137
 138 -- | Parameters used in Belenios.
 139 -- A 2048-bit 'fieldCharac' of a Finite Prime Field,
 140 -- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup
 141 -- generated by 'groupGen'.
 142 beleniosFFC :: FFC
 143 beleniosFFC = FFC
 144  { ffc_name        = "beleniosFFC"
 145  , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
 146  , ffc_groupGen    =  2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627
 147  , ffc_groupOrder  = 78571733251071885079927659812671450121821421258408794611510081919805623223441
 148  }
 149
 150 -- * Type 'F'
 151 -- | The type of the elements of a Finite Prime Field.
 152 --
 153 -- A field must satisfy the following properties:
 154 --
 155 -- * @(f, ('+'), 'zero')@ forms an abelian group,
 156 --   called the 'Additive' group of 'f'.
 157 --
 158 -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
 159 --   called the 'Multiplicative' group of 'f'.
 160 --
 161 -- * ('*') is associative:
 162 --   @(a'*'b)'*'c == a'*'(b'*'c)@ and
 163 --   @a'*'(b'*'c) == (a'*'b)'*'c@.
 164 --
 165 -- * ('*') and ('+') are both commutative:
 166 --   @a'*'b == b'*'a@ and
 167 --   @a'+'b == b'+'a@
 168 --
 169 -- * ('*') and ('+') are both left and right distributive:
 170 --   @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
 171 --   @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
 172 --
 173 -- The 'Natural' is always within @[0..'fieldCharac'-1]@.
 174 newtype F c = F { unF :: Natural }
 175  deriving (Eq,Ord,Show)
 176  deriving newtype NFData
 177 type instance FieldElement FFC = F
 178 instance Reifies c FFC => FromJSON (F c) where
 179         parseJSON (JSON.String s)
 180          | Just (c0,_) <- Text.uncons s
 181          , c0 /= '0'
 182          , Text.all Char.isDigit s
 183          , Just x <- readMaybe (Text.unpack s)
 184          , x < fieldCharac @c
 185          = return (F x)
 186         parseJSON json = JSON.typeMismatch "FieldElement FFC" json
 187 instance Reifies c FFC => FromJSON (G FFC c) where
 188         parseJSON (JSON.String s)
 189          | Just (c0,_) <- Text.uncons s
 190          , c0 /= '0'
 191          , Text.all Char.isDigit s
 192          , Just x <- readMaybe (Text.unpack s)
 193          , x < fieldCharac @c
 194          , r <- G (F x)
 195          , r ^ E (groupOrder @FFC (Proxy @c)) == one
 196          = return r
 197         parseJSON json = JSON.typeMismatch "GroupElement" json
 198 instance ToJSON (F c) where
 199         toJSON (F x) = JSON.toJSON (show x)
 200 instance Reifies c FFC => FromNatural (F c) where
 201         fromNatural i = F $ abs $ i `mod` fieldCharac @c
 202                 where
 203                 abs x | x < 0 = x + fieldCharac @c
 204                       | otherwise = x
 205 instance ToNatural (F c) where
 206         nat = unF
 207 instance Reifies c FFC => Additive (F c) where
 208         zero = F 0
 209         F x + F y = F $ (x + y) `mod` fieldCharac @c
 210 instance Reifies c FFC => Negable (F c) where
 211         neg (F x)
 212          | x == 0 = zero
 213          | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
 214 instance Reifies c FFC => Multiplicative (F c) where
 215         one = F 1
 216         F x * F y = F $ (x * y) `mod` fieldCharac @c
 217 instance Reifies c FFC => Random.Random (F c) where
 218         randomR (F lo, F hi) =
 219                 first (F . fromIntegral) .
 220                 Random.randomR
 221                  ( 0`max`toInteger lo
 222                  , toInteger hi`min`(toInteger (fieldCharac @c) - 1) )
 223         random =
 224                 first (F . fromIntegral) .
 225                 Random.randomR (0, toInteger (fieldCharac @c) - 1)
 226
 227 -- * Conversions
 228
 229 instance Key FFC where
 230         cryptoType _ = "FFC"
 231         cryptoName = ffc_name
 232         randomSecretKey = random
 233         credentialSecretKey (UUID uuid) (Credential cred) =
 234                 fromNatural $ decodeBigEndian $
 235                 Crypto.fastPBKDF2_SHA256
 236                  Crypto.Parameters
 237                  { Crypto.iterCounts   = 1000
 238                  , Crypto.outputLength = 32 -- bytes, ie. 256 bits
 239                  }
 240                  (Text.encodeUtf8 cred)
 241                  (Text.encodeUtf8 uuid)
 242         publicKey = (groupGen @FFC ^)