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

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DerivingStrategies #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE Rank2Types #-} -- for ReifyCrypto
   6 module Voting.Protocol.Arithmetic where
   7
   8 import Control.Arrow (first)
   9 import Control.DeepSeq (NFData)
  10 import Control.Monad (Monad(..))
  11 import Data.Aeson (ToJSON(..),FromJSON(..))
  12 import Data.Bits
  13 import Data.Bool
  14 import Data.Eq (Eq(..))
  15 import Data.Foldable (Foldable, foldl')
  16 import Data.Function (($), (.), id)
  17 import Data.Int (Int)
  18 import Data.Maybe (Maybe(..), fromJust)
  19 import Data.Ord (Ord(..))
  20 import Data.Proxy (Proxy(..))
  21 import Data.Reflection (Reifies(..))
  22 import Data.String (IsString(..))
  23 import GHC.Natural (minusNaturalMaybe)
  24 import Numeric.Natural (Natural)
  25 import Prelude (Integer, Bounded(..), Integral(..), fromIntegral)
  26 import Text.Read (readMaybe)
  27 import Text.Show (Show(..))
  28 import qualified Data.Aeson as JSON
  29 import qualified Data.Aeson.Types as JSON
  30 import qualified Data.ByteString as BS
  31 import qualified Data.Char as Char
  32 import qualified Data.Text as Text
  33 import qualified Prelude as Num
  34 import qualified System.Random as Random
  35
  36 -- * Class 'CryptoParams' where
  37 class
  38  ( EuclideanRing (G crypto c)
  39  , FromNatural   (G crypto c)
  40  , ToNatural     (G crypto c)
  41  , Eq            (G crypto c)
  42  , Ord           (G crypto c)
  43  , Show          (G crypto c)
  44  , NFData        (G crypto c)
  45  , FromJSON      (G crypto c)
  46  , ToJSON        (G crypto c)
  47  , Reifies c crypto
  48  ) => CryptoParams crypto c where
  49         -- | A generator of the subgroup.
  50         groupGen   :: G crypto c
  51         -- | The order of the subgroup.
  52         groupOrder :: Proxy c -> Natural
  53
  54         -- | 'groupGenPowers' returns the infinite list
  55         -- of powers of 'groupGen'.
  56         --
  57         -- NOTE: In the 'CryptoParams' class to keep
  58         -- computed values in memory across calls to 'groupGenPowers'.
  59         groupGenPowers :: [G crypto c]
  60         groupGenPowers = go one
  61                 where go g = g : go (g * groupGen)
  62
  63         -- | 'groupGenInverses' returns the infinite list
  64         -- of 'inverse' powers of 'groupGen':
  65         -- @['groupGen' '^' 'negate' i | i <- [0..]]@,
  66         -- but by computing each value from the previous one.
  67         --
  68         -- NOTE: In the 'CryptoParams' class to keep
  69         -- computed values in memory across calls to 'groupGenInverses'.
  70         --
  71         -- Used by 'intervalDisjunctions'.
  72         groupGenInverses :: [G crypto c]
  73         groupGenInverses = go one
  74                 where
  75                 invGen = inverse groupGen
  76                 go g = g : go (g * invGen)
  77
  78 -- ** Class 'ReifyCrypto'
  79 class ReifyCrypto crypto where
  80         -- | Like 'reify' but augmented with the 'CryptoParams' constraint.
  81         reifyCrypto :: crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r
  82
  83 -- * Class 'Additive'
  84 -- | An additive semigroup.
  85 class Additive a where
  86         zero :: a
  87         (+) :: a -> a -> a; infixl 6 +
  88         sum :: Foldable f => f a -> a
  89         sum = foldl' (+) zero
  90 instance Additive Natural where
  91         zero = 0
  92         (+)  = (Num.+)
  93 instance Additive Integer where
  94         zero = 0
  95         (+)  = (Num.+)
  96 instance Additive Int where
  97         zero = 0
  98         (+)  = (Num.+)
  99
 100 -- * Class 'Semiring'
 101 -- | A multiplicative semigroup, with an additive semigroup (aka. a semiring).
 102 class Additive a => Semiring a where
 103         one :: a
 104         (*) :: a -> a -> a; infixl 7 *
 105 instance Semiring Natural where
 106         one = 1
 107         (*) = (Num.*)
 108 instance Semiring Integer where
 109         one = 1
 110         (*) = (Num.*)
 111 instance Semiring Int where
 112         one = 1
 113         (*) = (Num.*)
 114
 115 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 116 (^) ::
 117  forall crypto c.
 118  Reifies c crypto =>
 119  Semiring (G crypto c) =>
 120  G crypto c -> E crypto c -> G crypto c
 121 (^) b (E e)
 122  | e == 0 = one
 123  | otherwise = t * (b*b) ^ E (e`shiftR`1)
 124         where t | testBit e 0 = b
 125                 | otherwise   = one
 126 infixr 8 ^
 127
 128 -- ** Class 'Ring'
 129 -- | A semiring that support substraction (aka. a ring).
 130 class Semiring a => Ring a where
 131         negate :: a -> a
 132         (-) :: a -> a -> a; infixl 6 -
 133         x-y = x + negate y
 134 instance Ring Integer where
 135         negate  = Num.negate
 136 instance Ring Int where
 137         negate  = Num.negate
 138
 139 -- ** Class 'EuclideanRing'
 140 -- | A commutative ring that support division (aka. an euclidean ring).
 141 class Ring a => EuclideanRing a where
 142         inverse :: a -> a
 143         (/) :: a -> a -> a; infixl 7 /
 144         x/y = x * inverse y
 145
 146 -- ** Type 'G'
 147 -- | The type of the elements of a subgroup of a field.
 148 newtype G crypto c = G { unG :: FieldElement crypto }
 149
 150 -- *** Type family 'FieldElement'
 151 type family FieldElement crypto :: *
 152
 153 -- ** Type 'E'
 154 -- | An exponent of a (cyclic) subgroup of a field.
 155 -- The value is always in @[0..'groupOrder'-1]@.
 156 newtype E crypto c = E { unE :: Natural }
 157  deriving (Eq,Ord,Show)
 158  deriving newtype NFData
 159 instance ToJSON (E crypto c) where
 160         toJSON = JSON.toJSON . show . unE
 161 instance CryptoParams crypto c => FromJSON (E crypto c) where
 162         parseJSON (JSON.String s)
 163          | Just (c0,_) <- Text.uncons s
 164          , c0 /= '0'
 165          , Text.all Char.isDigit s
 166          , Just x <- readMaybe (Text.unpack s)
 167          , x < groupOrder (Proxy @c)
 168          = return (E x)
 169         parseJSON json = JSON.typeMismatch "Exponent" json
 170 instance CryptoParams crypto c => FromNatural (E crypto c) where
 171         fromNatural n = E $ n `mod` groupOrder (Proxy @c)
 172 instance ToNatural (E crypto c) where
 173         nat = unE
 174 instance CryptoParams crypto c => Additive (E crypto c) where
 175         zero = E zero
 176         E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c)
 177 instance CryptoParams crypto c => Semiring (E crypto c) where
 178         one = E one
 179         E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c)
 180 instance CryptoParams crypto c => Ring (E crypto c) where
 181         negate (E x) = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`x
 182 instance CryptoParams crypto c => Random.Random (E crypto c) where
 183         randomR (E lo, E hi) =
 184                 first (E . fromIntegral) .
 185                 Random.randomR
 186                  ( 0`max`toInteger lo
 187                  , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) )
 188         random =
 189                 first (E . fromIntegral) .
 190                 Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1)
 191 instance CryptoParams crypto c => Enum (E crypto c) where
 192         toEnum = fromNatural . fromIntegral
 193         fromEnum = fromIntegral . nat
 194         enumFromTo lo hi = List.unfoldr
 195          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 196 instance CryptoParams crypto c => Bounded (E crypto c) where
 197         minBound = zero
 198         maxBound = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`1
 199
 200 -- * Class 'FromNatural'
 201 class FromNatural a where
 202         fromNatural :: Natural -> a
 203 instance FromNatural Natural where
 204         fromNatural = id
 205
 206 -- * Class 'ToNatural'
 207 class ToNatural a where
 208         nat :: a -> Natural
 209 instance ToNatural Natural where
 210         nat = id
 211
 212 -- | @('bytesNat' x)@ returns the serialization of 'x'.
 213 bytesNat :: ToNatural n => n -> BS.ByteString
 214 bytesNat = fromString . show . nat