{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Voting.Protocol.Arith where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..))
import Data.Aeson (ToJSON(..),FromJSON(..))
import Data.Bits
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldl')
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State.Strict as S
import qualified Crypto.Hash as Crypto
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLB
import qualified Prelude as Num
import qualified System.Random as Random
class Additive a where
zero :: a
(+) :: a -> a -> a; infixl 6 +
sum :: Foldable f => f a -> a
sum = foldl' (+) zero
instance Additive Natural where
zero = 0
(+) = (Num.+)
instance Additive Integer where
zero = 0
(+) = (Num.+)
instance Additive Int where
zero = 0
(+) = (Num.+)
class Additive a => Negable a where
neg :: a -> a
(-) :: a -> a -> a; infixl 6 -
x-y = x + neg y
instance Negable Integer where
neg = Num.negate
instance Negable Int where
neg = Num.negate
class Multiplicative a where
one :: a
(*) :: a -> a -> a; infixl 7 *
instance Multiplicative Natural where
one = 1
(*) = (Num.*)
instance Multiplicative Integer where
one = 1
(*) = (Num.*)
instance Multiplicative Int where
one = 1
(*) = (Num.*)
class Multiplicative a => Invertible a where
inv :: a -> a
(/) :: a -> a -> a; infixl 7 /
x/y = x * inv y
(^) ::
forall crypto c.
Reifies c crypto =>
Multiplicative (G crypto c) =>
G crypto c -> E crypto c -> G crypto c
(^) b (E e)
| e == 0 = one
| otherwise = t * (b*b) ^ E (e`shiftR`1)
where t | testBit e 0 = b
| otherwise = one
infixr 8 ^
class
( Multiplicative (G crypto c)
, Invertible (G crypto c)
, FromNatural (G crypto c)
, ToNatural (G crypto c)
, Eq (G crypto c)
, Ord (G crypto c)
, Show (G crypto c)
, NFData (G crypto c)
, FromJSON (G crypto c)
, ToJSON (G crypto c)
, Reifies c crypto
) => GroupParams crypto c where
groupGen :: G crypto c
groupOrder :: Proxy c -> Natural
groupGenPowers :: [G crypto c]
groupGenPowers = go one
where go g = g : go (g * groupGen)
groupGenInverses :: [G crypto c]
groupGenInverses = go one
where
invGen = inv $ groupGen
go g = g : go (g * invGen)
class ReifyCrypto crypto where
reifyCrypto :: crypto -> (forall c. Reifies c crypto => GroupParams crypto c => Proxy c -> r) -> r
newtype G crypto c = G { unG :: FieldElement crypto }
type family FieldElement crypto :: *
newtype E crypto c = E { unE :: Natural }
deriving (Eq,Ord,Show)
deriving newtype NFData
instance ToJSON (E crypto c) where
toJSON = JSON.toJSON . show . unE
instance GroupParams crypto c => FromJSON (E crypto c) where
parseJSON (JSON.String s)
| Just (c0,_) <- Text.uncons s
, c0 /= '0'
, Text.all Char.isDigit s
, Just x <- readMaybe (Text.unpack s)
, x < groupOrder (Proxy @c)
= return (E x)
parseJSON json = JSON.typeMismatch "Exponent" json
instance GroupParams crypto c => FromNatural (E crypto c) where
fromNatural i =
E $ abs $ i `mod` groupOrder (Proxy @c)
where
abs x | x < 0 = x + groupOrder (Proxy @c)
| otherwise = x
instance ToNatural (E crypto c) where
nat = unE
instance GroupParams crypto c => Additive (E crypto c) where
zero = E zero
E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c)
instance GroupParams crypto c => Negable (E crypto c) where
neg (E x)
| x == 0 = zero
| otherwise = E $ fromJust $ nat (groupOrder (Proxy @c))`minusNaturalMaybe`x
instance GroupParams crypto c => Multiplicative (E crypto c) where
one = E one
E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c)
instance GroupParams crypto c => Random.Random (E crypto c) where
randomR (E lo, E hi) =
first (E . fromIntegral) .
Random.randomR
( 0`max`toInteger lo
, toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) )
random =
first (E . fromIntegral) .
Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1)
instance GroupParams crypto c => Enum (E crypto c) where
toEnum = fromNatural . fromIntegral
fromEnum = fromIntegral . nat
enumFromTo lo hi = List.unfoldr
(\i -> if i<=hi then Just (i, i+one) else Nothing) lo
class FromNatural a where
fromNatural :: Natural -> a
class ToNatural a where
nat :: a -> Natural
instance ToNatural Natural where
nat = id
bytesNat :: ToNatural n => n -> BS.ByteString
bytesNat = fromString . show . nat
newtype Hash crypto c = Hash (E crypto c)
deriving newtype (Eq,Ord,Show,NFData)
hash :: GroupParams crypto c => BS.ByteString -> [G crypto c] -> E crypto c
hash bs gs = do
let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)
let h = Crypto.hashWith Crypto.SHA256 s
fromNatural $
decodeBigEndian $ ByteArray.convert h
decodeBigEndian :: BS.ByteString -> Natural
decodeBigEndian =
BS.foldl'
(\acc b -> acc`shiftL`8 + fromIntegral b)
(0::Natural)
newtype Base64SHA256 = Base64SHA256 Text
deriving (Eq,Ord,Show,Generic)
deriving anyclass (ToJSON,FromJSON)
deriving newtype NFData
base64SHA256 :: BS.ByteString -> Base64SHA256
base64SHA256 bs =
let h = Crypto.hashWith Crypto.SHA256 bs in
Base64SHA256 $
Text.takeWhile (/= '=') $
Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h
newtype HexSHA256 = HexSHA256 Text
deriving (Eq,Ord,Show,Generic)
deriving anyclass (ToJSON,FromJSON)
deriving newtype NFData
hexSHA256 :: BS.ByteString -> Text
hexSHA256 bs =
let h = Crypto.hashWith Crypto.SHA256 bs in
let n = decodeBigEndian $ ByteArray.convert h in
TL.toStrict $
TL.tail $ TLB.toLazyText $ TLB.hexadecimal $
setBit n 256
randomR ::
Monad m =>
Random.RandomGen r =>
Random.Random i =>
Negable i =>
Multiplicative i =>
i -> S.StateT r m i
randomR i = S.StateT $ return . Random.randomR (zero, i-one)
random ::
Monad m =>
Random.RandomGen r =>
Random.Random i =>
Negable i =>
Multiplicative i =>
S.StateT r m i
random = S.StateT $ return . Random.random
instance Random.Random Natural where
randomR (mini,maxi) =
first (fromIntegral::Integer -> Natural) .
Random.randomR (fromIntegral mini, fromIntegral maxi)
random = first (fromIntegral::Integer -> Natural) . Random.random