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