module Protocol.Arithmetic where

import Control.Arrow (first)
import Control.Monad (Monad(..))
import Data.Bits
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldl', foldMap)
import Data.Function (($), (.), on)
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State.Strict as S
import qualified Crypto.Hash as Crypto
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.List as List
import qualified Prelude as N
import qualified System.Random as Random

-- * Type 'F'
-- | The type of the elements of a 'PrimeField'.
--
-- A field must satisfy the following properties:
--
-- * @(f, ('+'), 'zero')@ forms an abelian group,
--   called the 'Additive' group of 'f'.
--
-- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
--   called the 'Multiplicative' group of 'f'.
--
-- * ('*') is associative:
--   @(a'*'b)'*'c == a'*'(b'*'c)@ and
--   @a'*'(b'*'c) == (a'*'b)'*'c@.
--
-- * ('*') and ('+') are both commutative:
--   @a'*'b == b'*'a@ and
--   @a'+'b == b'+'a@
--
-- * ('*') and ('+') are both left and right distributive:
--   @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
--   @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
--
-- The 'Integer' is always within @[0..'fieldCharac'-1]@.
newtype F p = F { unF :: Integer }
 deriving (Eq,Ord,Show)

inF :: forall p i. PrimeField p => Integral i => i -> F p
inF i = F (abs (fromIntegral i `mod` fieldCharac @p))
	where abs x | x < 0 = x + fieldCharac @p
	            | otherwise = x

instance PrimeField p => Additive (F p) where
	zero = F 0
	F x + F y = F ((x + y) `mod` fieldCharac @p)
instance PrimeField p => Negable (F p) where
	neg (F x) | x == 0 = zero
	          | otherwise = F (N.negate x + fieldCharac @p)
instance PrimeField p => Multiplicative (F p) where
	one = F 1
	-- | Because 'fieldCharac' is prime,
	-- all elements of the field are invertible modulo 'fieldCharac'.
	F x * F y = F ((x * y) `mod` fieldCharac @p)
instance PrimeField p => Random.Random (F p) where
	randomR (F lo, F hi) =
		first F . Random.randomR
		 (max 0 lo, min hi (fieldCharac @p - 1))
	random = first F . Random.randomR (0, fieldCharac @p - 1)

-- ** Class 'PrimeField'
-- | Parameter for a prime field.
class PrimeField p where
	-- | The prime number characteristic of a 'PrimeField'.
	--
	-- ElGamal's hardness to decrypt requires a large prime number
	-- to form the 'Multiplicative' 'SubGroup'.
	fieldCharac :: Integer

-- ** Class 'Additive'
class Additive a where
	zero :: a
	(+) :: a -> a -> a; infixl 6 +
	sum :: Foldable f => f a -> a
	sum = foldl' (+) zero
instance Additive Integer where
	zero = 0
	(+)  = (N.+)
instance Additive Int where
	zero = 0
	(+)  = (N.+)

-- *** Class 'Negable'
class Additive a => Negable a where
	neg :: a -> a
	(-) :: a -> a -> a; infixl 6 -
	x-y = x + neg y
instance Negable Integer where
	neg  = N.negate
instance Negable Int where
	neg  = N.negate

-- ** Class 'Multiplicative'
class Multiplicative a where
	one :: a
	(*) :: a -> a -> a; infixl 7 *
instance Multiplicative Integer where
	one = 1
	(*) = (N.*)
instance Multiplicative Int where
	one = 1
	(*) = (N.*)

-- ** Class 'Invertible'
class Multiplicative a => Invertible a where
	inv :: a -> a
	(/) :: a -> a -> a; infixl 7 /
	x/y = x * inv y

-- * Type 'G'
-- | The type of the elements of a 'Multiplicative' 'SubGroup' of a 'PrimeField'.
newtype G q = G { unG :: F (P q) }
 deriving (Eq,Ord,Show)

-- | @('intG' g)@ returns the element of the 'SubGroup' 'g'
-- as an 'Integer' within @[0..'fieldCharac'-1]@.
intG :: SubGroup q => G q -> Integer
intG = unF . unG

instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (G q) where
	one = G one
	G x * G y = G (x * y)
instance (SubGroup q, Multiplicative (F (P q))) => Invertible (G q) where
	-- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
	inv = (^ (E (neg one + groupOrder @q)))

-- ** Class 'SubGroupOfPrimeField'
-- | A 'SubGroup' of a 'PrimeField'.
-- Used for signing (Schnorr) and encrypting (ElGamal).
class
 ( PrimeField (P q)
 , Multiplicative (F (P q))
 ) => SubGroup q where
	-- | Setting 'q' determines 'p', equals to @'P' q@.
	type P q :: *
	-- | A generator of the 'SubGroup'.
	-- NOTE: since @F p@ is a 'PrimeField',
	-- the 'Multiplicative' 'SubGroup' is cyclic,
	-- and there are phi('fieldCharac'-1) many choices for the generator of the group,
	-- where phi is the Euler totient function.
	groupGen :: G q
	-- | The order of the 'SubGroup'.
	--
	-- WARNING: 'groupOrder' MUST be a prime number dividing @('fieldCharac'-1)@
	-- to ensure that ensures that ElGamal is secure in terms
	-- of the DDH assumption.
	groupOrder :: F (P q)
	
	-- | 'groupGenInverses' returns the infinite list
	-- of 'inv'erse powers of 'groupGen':
	-- @['groupGen' '^' 'neg' i | i <- [0..]]@,
	-- but by computing each value from the previous one.
	--
	-- NOTE: 'groupGenInverses' is in the 'SubGroup' class in order to keep
	-- computed terms in memory accross calls to 'groupGenInverses'.
	--
	-- Used by 'elgamalDisjProve'.
	groupGenInverses :: [G q]
	groupGenInverses = go one
		where
		go g = g : go (g * invGen)
		invGen = inv groupGen

-- | @('hash' prefix gs)@ returns as a number in @('F' p)@
-- the SHA256 of the given 'prefix' prefixing the decimal representation
-- of given 'SubGroup' elements 'gs', each one postfixed with a comma (",").
hash ::
 SubGroup q =>
 BS.ByteString -> [G q] -> E q
hash prefix gs =
	let s = prefix <> foldMap (\(G (F i)) -> fromString (show i) <> fromString ",") gs in
	let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) in
	inE (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Integer) h)

-- * Type 'E'
-- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.
-- The value is always in @[0..'groupOrder'-1]@.
newtype E q = E { unE :: F (P q) }
 deriving (Eq,Ord,Show)

inE :: forall q i. SubGroup q => Integral i => i -> E q
inE i = E (F (abs (fromIntegral i `mod` unF (groupOrder @q))))
	where abs x | x < 0 = x + unF (groupOrder @q)
	            | otherwise = x

intE :: forall q. SubGroup q => E q -> Integer
intE = unF . unE

instance (SubGroup q, Additive (F (P q))) => Additive (E q) where
	zero = E zero
	E (F x) + E (F y) = E (F ((x + y) `mod` unF (groupOrder @q)))
instance (SubGroup q, Negable (F (P q))) => Negable (E q) where
	neg (E (F x)) | x == 0 = zero
	              | otherwise = E (F (neg x + unF (groupOrder @q)))
instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (E q) where
	one = E one
	E (F x) * E (F y) = E (F ((x * y) `mod` unF (groupOrder @q)))
instance SubGroup q => Random.Random (E q) where
	randomR (E (F lo), E (F hi)) =
		first (E . F) . Random.randomR
		 (max 0 lo, min hi (unF (groupOrder @q) - 1))
	random = first (E . F) . Random.randomR (0, unF (groupOrder @q) - 1)
instance SubGroup q => Enum (E q) where
	toEnum = inE
	fromEnum = fromIntegral . intE
	enumFromTo lo hi = List.unfoldr
	 (\i -> if i<=hi then Just (i, i+one) else Nothing) lo

infixr 8 ^
-- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
(^) :: SubGroup q => G q -> E q -> G q
(^) b (E (F e))
 | e == zero = one
 | otherwise = t * (b*b) ^ E (F (e`shiftR`1))
	where
	t | testBit e 0 = b
		| otherwise   = one

-- * Type 'RandomGen'
type RandomGen = Random.RandomGen

randomR ::
 Monad m =>
 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 =>
 RandomGen r =>
 Random.Random i =>
 Negable i =>
 Multiplicative i =>
 S.StateT r m i
random = S.StateT $ return . Random.random

-- * Groups

-- ** Type 'WeakParams'
-- | Weak parameters for debugging purposes only.
data WeakParams
instance PrimeField WeakParams where
	fieldCharac = 263
instance SubGroup WeakParams where
	type P WeakParams = WeakParams
	groupGen = G (F 2)
	groupOrder = F 131

-- ** Type 'BeleniosParams'
-- | Parameters used in Belenios.
-- A 2048-bit 'fieldCharac' of a 'PrimeField',
-- with a 256-bit 'groupOrder' for a 'Multiplicative' 'SubGroup'
-- generated by 'groupGen',
data BeleniosParams
instance PrimeField BeleniosParams where
	fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
instance SubGroup BeleniosParams where
	type P BeleniosParams = BeleniosParams
	groupGen = G (F 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627)
	groupOrder = F 78571733251071885079927659812671450121821421258408794611510081919805623223441