-
Notifications
You must be signed in to change notification settings - Fork 463
/
Common.hs
237 lines (187 loc) · 7.49 KB
/
Common.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Evaluation.Builtins.BLS12_381.Common
where
import Evaluation.Builtins.Common
import PlutusCore.BLS12_381.G1 qualified as G1
import PlutusCore.BLS12_381.G2 qualified as G2
import Crypto.EllipticCurve.BLS12_381 (BLSTError)
import PlutusCore as PLC
import PlutusCore.Default
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp)
import UntypedPlutusCore as UPLC
import PlutusCore.Generators.QuickCheck.Builtin
import Test.QuickCheck hiding ((.&.))
import Data.Bits (complement, xor, (.&.), (.|.))
import Data.ByteString as BS (ByteString, cons, pack, uncons)
import Data.Word (Word8)
import Text.Printf (printf)
-- PLC utilities
-- Evaluating PLC terms
type PlcTerm = PLC.Term TyName Name DefaultUni DefaultFun ()
type UplcTerm = UPLC.Term Name DefaultUni DefaultFun ()
data CekResult =
TypeCheckEvaluateError (Error DefaultUni DefaultFun ())
| CekError
| CekSuccess UplcTerm
deriving stock (Eq, Show)
evalTerm :: PlcTerm -> CekResult
evalTerm term =
case typecheckEvaluateCekNoEmit DefaultFunV1 defaultBuiltinCostModel term
of Left e -> TypeCheckEvaluateError e
Right x ->
case x of
EvaluationFailure -> CekError
EvaluationSuccess s -> CekSuccess s
-- Constructing PLC constants and applications
uplcTrue :: CekResult
uplcTrue = CekSuccess $ mkConstant () True
uplcFalse :: CekResult
uplcFalse = CekSuccess $ mkConstant () False
integer :: Integer -> PlcTerm
integer = mkConstant ()
bytestring :: ByteString -> PlcTerm
bytestring = mkConstant ()
mkApp1 :: DefaultFun -> PlcTerm -> PlcTerm
mkApp1 b x = mkIterApp () (builtin () b) [x]
mkApp2 :: DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 b x y = mkIterApp () (builtin () b) [x,y]
-- Constructing pairing terms
pairingPlc :: PlcTerm -> PlcTerm -> PlcTerm
pairingPlc = mkApp2 Bls12_381_pairing
mulMlResultPlc :: PlcTerm -> PlcTerm -> PlcTerm
mulMlResultPlc = mkApp2 Bls12_381_mulMlResult
finalVerifyPlc :: PlcTerm -> PlcTerm -> PlcTerm
finalVerifyPlc = mkApp2 Bls12_381_finalVerify
-- ByteString utilities
-- The most siginificant bit of a serialised curve point is set if the
-- serialised point is in compressed form (x-coordinate only)
compressionBit :: Word8
compressionBit = 0x80
-- The second most significant bit is set if and only if the point is the point
-- at infinity (the zero of the group); if it is set, all other bits should be zero.
infinityBit :: Word8
infinityBit = 0x40
-- The third most significant bit of a compressed point denotes the "sign" of
-- the y-coordinate of the associated point : it is set if and only if point is
-- not the point at infinity and the y-coordinate is the lexicographically
-- larger one with the given x coordinate.
signBit :: Word8
signBit = 0x20
unsafeUnconsBS :: ByteString -> (Word8, ByteString)
unsafeUnconsBS b =
case BS.uncons b of
Nothing -> error "Tried to uncons empty bytestring"
Just p -> p
-- Apply some function to the most significant byte of a bytestring
modifyMSB :: (Word8 -> Word8) -> ByteString -> ByteString
modifyMSB f s =
let (w,rest) = unsafeUnconsBS s
in BS.cons (f w) rest
flipBits :: Word8 -> ByteString -> ByteString
flipBits mask = modifyMSB (mask `xor`)
clearBits :: Word8 -> ByteString -> ByteString
clearBits mask = modifyMSB ((complement mask) .&.)
setBits :: Word8 -> ByteString -> ByteString
setBits mask = modifyMSB (mask .|.)
isSet :: Word8 -> ByteString -> Bool
isSet mask s =
let (w,_) = unsafeUnconsBS s
in w .&. mask /= 0
fix :: ByteString -> ByteString
fix s =
let (_,s1) = unsafeUnconsBS s
(_,s2) = unsafeUnconsBS s1
in BS.cons 0x80 (BS.cons 0x00 s2)
---------------- Typeclasses for groups ----------------
-- | The code for the property tests for G1 and G2 is essentially identical, so
-- it's worth abstracting over the common features. The blst Haskell FFI uses a
-- phantom type to do this but unfortunately we have to hide that to stop the
-- builtin machinery spotting it and then we have to re-abstract here.
-- | We could re-use the AbelianGroup class here, but that uses <> and `mempty`
-- and that's kind of confusing.
class (Eq a, Show a, Arbitrary a, ArbitraryBuiltin a) => TestableAbelianGroup a
where
gname :: String
zero :: a
add :: a -> a -> a
neg :: a -> a
scalarMul :: Integer -> a -> a
zeroP :: PlcTerm
addP :: PlcTerm -> PlcTerm -> PlcTerm
negP :: PlcTerm -> PlcTerm
scalarMulP :: PlcTerm -> PlcTerm -> PlcTerm
eqP :: PlcTerm -> PlcTerm -> PlcTerm
toPlc :: a -> PlcTerm
class TestableAbelianGroup a => HashAndCompress a
where
hashTo :: ByteString -> a
compress :: a -> ByteString
uncompress :: ByteString -> Either BLSTError a
compressedSize :: Int
compressP :: PlcTerm -> PlcTerm
uncompressP :: PlcTerm -> PlcTerm
hashToCurveP :: PlcTerm -> PlcTerm
-- | Generate an arbitrary element of G1. It's tricky to construct such an
-- element directly without using quite low-level operations on the curve
-- because a random point on the curve is highly unlikely to be in the subgroup
-- G1, but fortunately `hashToCurve` always produces an element of the subgroup,
-- so we can produce random elements of G1 by hasing random bytestrings.
instance Arbitrary G1.Element
where
arbitrary = G1.hashToCurve <$> arbitrary
instance TestableAbelianGroup G1.Element
where
gname = "G1"
zero = G1.zero
add = G1.add
neg = G1.neg
scalarMul = G1.scalarMul
zeroP = mkApp1 Bls12_381_G1_uncompress $ bytestring $ pack (0xc0 : replicate 47 0x00)
addP = mkApp2 Bls12_381_G1_add
negP = mkApp1 Bls12_381_G1_neg
scalarMulP = mkApp2 Bls12_381_G1_scalarMul
eqP = mkApp2 Bls12_381_G1_equal
toPlc = mkConstant ()
instance HashAndCompress G1.Element
where
hashTo = G1.hashToCurve
compress = G1.compress
uncompress = G1.uncompress
compressedSize = 48
compressP = mkApp1 Bls12_381_G1_compress
uncompressP = mkApp1 Bls12_381_G1_uncompress
hashToCurveP = mkApp1 Bls12_381_G1_hashToCurve
-- | See the comment for the Arbitrary instance for G1.
instance Arbitrary G2.Element
where
arbitrary = G2.hashToCurve <$> arbitrary
instance TestableAbelianGroup G2.Element
where
gname = "G2"
zero = G2.zero
add = G2.add
neg = G2.neg
scalarMul = G2.scalarMul
zeroP = mkApp1 Bls12_381_G2_uncompress $ bytestring $ pack (0xc0 : replicate 95 0x00)
addP = mkApp2 Bls12_381_G2_add
negP = mkApp1 Bls12_381_G2_neg
scalarMulP = mkApp2 Bls12_381_G2_scalarMul
eqP = mkApp2 Bls12_381_G2_equal
toPlc = mkConstant ()
instance HashAndCompress G2.Element
where
hashTo = G2.hashToCurve
compress = G2.compress
uncompress = G2.uncompress
compressedSize = 96
compressP = mkApp1 Bls12_381_G2_compress
uncompressP = mkApp1 Bls12_381_G2_uncompress
hashToCurveP = mkApp1 Bls12_381_G2_hashToCurve
-- QuickCheck utilities
mkTestName :: forall a. TestableAbelianGroup a => String -> String
mkTestName s = printf "%s_%s" (gname @a) s
withNTests :: Testable prop => prop -> Property
withNTests = withMaxSuccess 200