]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/src/Voting/Protocol/Arithmetic.hs
cli: admin: directly use election_hash
[majurity.git] / 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