{-# LANGUAGE CPP, DataKinds, DerivingStrategies, KindSignatures, NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables, Trustworthy #-}
module Fields (Field(..), Fz(..), Num(..)) where
import Prelude hiding (concat, replicate)
import Crypto.Hash (Blake2b_512 (Blake2b_512), hashWith)
import Data.Bifunctor (bimap)
import Data.Bits ((.|.), shiftL, shiftR)
import Data.ByteArray (convert, length, xor)
import Data.ByteString (concat, foldl', pack, replicate)
import Data.ByteString.UTF8 (ByteString, fromString)
import Data.Char (chr)
import Data.Typeable (Proxy (Proxy))
import GHC.Word (Word8)
import GHC.TypeLits (KnownNat, Nat, natVal)
newtype Fz (z :: Nat) = Fz Integer deriving stock (Fz z -> Fz z -> Bool
(Fz z -> Fz z -> Bool) -> (Fz z -> Fz z -> Bool) -> Eq (Fz z)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (z :: Nat). Fz z -> Fz z -> Bool
/= :: Fz z -> Fz z -> Bool
$c/= :: forall (z :: Nat). Fz z -> Fz z -> Bool
== :: Fz z -> Fz z -> Bool
$c== :: forall (z :: Nat). Fz z -> Fz z -> Bool
Eq)
#define MOD natVal (Proxy :: Proxy z)
instance KnownNat z => Num (Fz z) where
fromInteger :: Integer -> Fz z
fromInteger Integer
a = Integer -> Fz z
forall (z :: Nat). Integer -> Fz z
Fz (Integer -> Fz z) -> Integer -> Fz z
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` MOD
+ :: Fz z -> Fz z -> Fz z
(+) (Fz Integer
a) (Fz Integer
b) = Integer -> Fz z
forall a. Num a => Integer -> a
fromInteger (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b)
(-) (Fz Integer
a) (Fz Integer
b) = Integer -> Fz z
forall a. Num a => Integer -> a
fromInteger (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
b)
* :: Fz z -> Fz z -> Fz z
(*) (Fz Integer
a) (Fz Integer
b) = Integer -> Fz z
forall a. Num a => Integer -> a
fromInteger (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b)
abs :: Fz z -> Fz z
abs = [Char] -> Fz z -> Fz z
forall a. HasCallStack => [Char] -> a
error [Char]
"abs: not implemented/needed"
signum :: Fz z -> Fz z
signum = [Char] -> Fz z -> Fz z
forall a. HasCallStack => [Char] -> a
error [Char]
"signum: not implemented/needed"
instance KnownNat z => Show (Fz z) where
show :: Fz z -> [Char]
show (Fz Integer
a) = [Char]
"0x" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]
"0123456789ABCDEF" [Char] -> Int -> Char
forall a. [a] -> Int -> a
!! Int -> Int
nibble Int
n | Int
n <- [Int
e, Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
0]]
where
nibble :: Int -> Int
nibble :: Int -> Int
nibble Int
n = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftR Integer
a (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
4) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
16
e :: Int
e = ((Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> Bool) -> (Int -> Int) -> Int -> Int
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((MOD <) . (2 ^)) (+ 1) 0) `div(Integer -> Bool) -> (Int -> Integer) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
` 4Integer
) Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
- 1 :: Int
class (Num a, Eq a) => Field a where
fromBytesF :: ByteString -> Maybe a
_fromBytesF :: ByteString -> a
hash2Field :: ByteString -> String -> String -> (a, a)
inv0 :: a -> a
isSqr :: a -> Bool
sgn0 :: a -> Integer
shiftR1 :: a -> a
sqrt :: a -> Maybe a
toBytesF :: a -> ByteString
toI :: a -> Integer
instance KnownNat z => Field (Fz z) where
fromBytesF :: ByteString -> Maybe (Fz z)
fromBytesF ByteString
bytes | ByteString -> Int
forall ba. ByteArrayAccess ba => ba -> Int
Data.ByteArray.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
corLen Bool -> Bool -> Bool
|| Integer
integer Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= MOD = Nothing
| Bool
otherwise = Fz z -> Maybe (Fz z)
forall a. a -> Maybe a
Just (Fz z -> Maybe (Fz z)) -> Fz z -> Maybe (Fz z)
forall a b. (a -> b) -> a -> b
$ Integer -> Fz z
forall a. Num a => Integer -> a
fromInteger Integer
integer
where
corLen :: Int
corLen = (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> Bool) -> (Int -> Int) -> Int -> Int
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((MOD <) . (2 ^)) (+ 1) 0) `div(Integer -> Bool) -> (Int -> Integer) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
` 8 :: Int
integer :: Integer
integer = (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
foldl' (\Integer
a Word8
b -> Integer
a Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Integer
0 ByteString
bytes :: Integer
_fromBytesF :: ByteString -> Fz z
_fromBytesF ByteString
bytes = Integer -> Fz z
forall a. Num a => Integer -> a
fromInteger (Integer -> Fz z) -> Integer -> Fz z
forall a b. (a -> b) -> a -> b
$ (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
foldl' (\Integer
a Word8
b -> Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
a Int
8 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Integer
0 ByteString
bytes
hash2Field :: ByteString -> [Char] -> [Char] -> (Fz z, Fz z)
hash2Field ByteString
msg [Char]
domPref [Char]
curveId
| Int
22 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Char]
curveId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Char]
domPref Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255 = [Char] -> (Fz z, Fz z)
forall a. HasCallStack => [Char] -> a
error [Char]
"strings too long"
| Bool
otherwise = (ByteString -> Fz z)
-> (ByteString -> Fz z) -> (ByteString, ByteString) -> (Fz z, Fz z)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> Fz z
forall a. Field a => ByteString -> a
_fromBytesF ByteString -> Fz z
forall a. Field a => ByteString -> a
_fromBytesF (ByteString
digest1, ByteString
digest2)
where
prefix :: ByteString
prefix = Int -> Word8 -> ByteString
replicate Int
128 Word8
0
suffix :: ByteString
suffix = [Char] -> ByteString
fromString ([Char]
domPref [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
curveId [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_XMD:BLAKE2b_SSWU_RO_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
[Int -> Char
chr (Int
22 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Char]
curveId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Char]
domPref)])
mkDigest :: ByteString -> ByteString
mkDigest :: ByteString -> ByteString
mkDigest ByteString
x = Digest Blake2b_512 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest Blake2b_512 -> ByteString)
-> Digest Blake2b_512 -> ByteString
forall a b. (a -> b) -> a -> b
$ Blake2b_512 -> ByteString -> Digest Blake2b_512
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith Blake2b_512
Blake2b_512 ByteString
x
digest0 :: ByteString
digest0 = ByteString -> ByteString
mkDigest (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
concat [ByteString
prefix, ByteString
msg, [Word8] -> ByteString
pack [Word8
0,Word8
0x80,Word8
0], ByteString
suffix]
digest1 :: ByteString
digest1 = ByteString -> ByteString
mkDigest (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
concat [ByteString
digest0, [Word8] -> ByteString
pack [Word8
0x01], ByteString
suffix]
mix :: ByteString
mix = ByteString -> ByteString -> ByteString
forall a b c.
(ByteArrayAccess a, ByteArrayAccess b, ByteArray c) =>
a -> b -> c
xor ByteString
digest0 ByteString
digest1 :: ByteString
digest2 :: ByteString
digest2 = ByteString -> ByteString
mkDigest (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
concat [ByteString
mix, [Word8] -> ByteString
pack [Word8
0x02], ByteString
suffix]
inv0 :: Fz z -> Fz z
inv0 (Fz Integer
a) = Integer -> Fz z
forall (z :: Nat). Integer -> Fz z
Fz (Integer -> Fz z) -> Integer -> Fz z
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer -> Integer
_powMod Integer
a (MOD - 2) (MOD)
isSqr :: Fz z -> Bool
isSqr (Fz Integer
a) = Integer -> Integer -> Bool
_isSqr Integer
a (MOD)
sgn0 :: Fz z -> Integer
sgn0 (Fz Integer
a) = Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
2
shiftR1 :: Fz z -> Fz z
shiftR1 (Fz Integer
a) = Integer -> Fz z
forall (z :: Nat). Integer -> Fz z
Fz (Integer -> Fz z) -> Integer -> Fz z
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2
sqrt :: Fz z -> Maybe (Fz z)
sqrt (Fz Integer
a) = Integer -> Fz z
forall a. Num a => Integer -> a
fromInteger (Integer -> Fz z) -> Maybe Integer -> Maybe (Fz z)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer
-> Integer -> Integer -> Integer -> Integer -> Maybe Integer
_sqrtVt Integer
a (MOD) s p c
where
s :: Integer
s = (Integer -> Bool) -> (Integer -> Integer) -> Integer -> Integer
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0) (Integer -> Bool) -> (Integer -> Integer) -> Integer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((MOD -1) Proxy z
forall k (t :: k). Proxy t
`rem`) . (2 ^)) (+ Integer
1) 0 - 1 :: Integer
p :: Integer
p = (MOD - 1) `div` (2 ^ s)
z :: Integer
z = [Integer] -> Integer
forall a. [a] -> a
head ([Integer
x | Integer
x <- [Integer
1..], Bool -> Bool
not (Integer -> Integer -> Bool
_isSqr Integer
x (MOD))] ++ [0])
c :: Integer
c = Integer -> Integer -> Integer -> Integer
_powMod Integer
z Integer
p (MOD)
toBytesF :: Fz z -> ByteString
toBytesF (Fz Integer
a) = [Word8] -> ByteString
pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
res
where
corLen :: Int
corLen = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ (Integer
7 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer -> Bool) -> (Integer -> Integer) -> Integer -> Integer
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((MOD <) . (2 ^)) (+ 1) 0) `div(Integer -> Bool) -> (Integer -> Integer) -> Integer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
` 8 :: Int
res :: [Word8]
res = [Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftR Integer
a (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
b)) | Int
b <- [Int
0..(Int
corLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]] :: [Word8]
toI :: Fz z -> Integer
toI (Fz Integer
a) = Integer
a
_powMod :: Integer -> Integer -> Integer -> Integer
_powMod :: Integer -> Integer -> Integer -> Integer
_powMod Integer
_ Integer
e Integer
q | Integer
e Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
q Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2 = [Char] -> Integer
forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid exponent/modulus"
_powMod Integer
_ Integer
0 Integer
_ = Integer
1
_powMod Integer
a Integer
1 Integer
_ = Integer
a
_powMod Integer
a Integer
e Integer
q | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
e = Integer -> Integer -> Integer -> Integer
_powMod (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
q) (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftR Integer
e Int
1) Integer
q
| Bool
otherwise = Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer -> Integer -> Integer -> Integer
_powMod Integer
a (Integer
e Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer
q Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
q
_isSqr :: Integer -> Integer -> Bool
_isSqr :: Integer -> Integer -> Bool
_isSqr Integer
a Integer
q = (Integer
legendreSymbol Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) Bool -> Bool -> Bool
|| (Integer
legendreSymbol Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1)
where legendreSymbol :: Integer
legendreSymbol = Integer -> Integer -> Integer -> Integer
_powMod Integer
a ((Integer
q Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer
q
_sqrtVt :: Integer -> Integer -> Integer -> Integer -> Integer -> Maybe Integer
_sqrtVt :: Integer
-> Integer -> Integer -> Integer -> Integer -> Maybe Integer
_sqrtVt Integer
0 Integer
_ Integer
_ Integer
_ Integer
_ = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0
_sqrtVt Integer
a Integer
q Integer
_ Integer
_ Integer
_ | Bool -> Bool
not (Integer -> Integer -> Bool
_isSqr Integer
a Integer
q) = Maybe Integer
forall a. Maybe a
Nothing
_sqrtVt Integer
_ Integer
_ Integer
_ Integer
_ Integer
0 = Maybe Integer
forall a. Maybe a
Nothing
_sqrtVt Integer
a Integer
q Integer
s Integer
p Integer
c = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
result
where
t :: Integer
t = Integer -> Integer -> Integer -> Integer
_powMod Integer
a Integer
p Integer
q
r :: Integer
r = Integer -> Integer -> Integer -> Integer
_powMod Integer
a ((Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer
q
result :: Integer
result = Integer -> Integer -> Integer -> Integer -> Integer
loopy Integer
t Integer
r Integer
c Integer
s
loopy :: Integer -> Integer -> Integer -> Integer -> Integer
loopy :: Integer -> Integer -> Integer -> Integer -> Integer
loopy Integer
tt Integer
_ Integer
_ Integer
ss | Integer
tt Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
|| Integer
ss Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = Integer
0
loopy Integer
1 Integer
rr Integer
_ Integer
_ = Integer
rr
loopy Integer
tt Integer
rr Integer
cc Integer
ss = Integer -> Integer -> Integer -> Integer -> Integer
loopy Integer
t_n Integer
r_n Integer
c_n Integer
s_n
where
s_n :: Integer
s_n = [Integer] -> Integer
forall a. [a] -> a
head ([Integer
i | Integer
i <- [Integer
1..(Integer
ss Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)], Integer -> Integer -> Integer -> Integer
_powMod Integer
tt (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
i) Integer
q Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1] [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer
0])
ff :: Integer
ff = Integer -> Integer -> Integer -> Integer
_powMod Integer
cc (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
ss Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
s_n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)) Integer
q
r_n :: Integer
r_n = Integer
rr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ff Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
q
t_n :: Integer
t_n = (Integer
tt Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer -> Integer -> Integer -> Integer
_powMod Integer
ff Integer
2 Integer
q) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
q
c_n :: Integer
c_n = Integer -> Integer -> Integer -> Integer
_powMod Integer
cc (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
ss Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
s_n)) Integer
q