diff options
| -rw-r--r-- | programmingbitcoin.cabal | 36 | ||||
| -rw-r--r-- | src/Ecc.hs | 226 |
2 files changed, 117 insertions, 145 deletions
diff --git a/programmingbitcoin.cabal b/programmingbitcoin.cabal index 11cda1a..0232710 100644 --- a/programmingbitcoin.cabal +++ b/programmingbitcoin.cabal @@ -2,27 +2,6 @@ cabal-version: 2.4 name: programmingbitcoin version: 0.1.0.0 --- A short (one-line) description of the package. --- synopsis: - --- A longer description of the package. --- description: - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. --- license: -author: Óscar Nájera -maintainer: hi@oscarnajera.com - --- A copyright notice. --- copyright: --- category: -extra-source-files: - CHANGELOG.md - readme.org - library hs-source-dirs: src exposed-modules: Ecc @@ -30,18 +9,3 @@ library , bytestring >= 0.10.12.0 , cryptohash-sha256 default-language: Haskell2010 - -executable programmingbitcoin - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - build-depends: base ^>=4.14.1.0 - , binary >= 0.8.8.0 - , bytestring >= 0.10.12.0 - , cryptohash-sha256 - hs-source-dirs: app - default-language: Haskell2010 @@ -28,28 +28,13 @@ instance KnownNat n => Num (FieldElement n) where instance KnownNat n => Fractional (FieldElement n) where recip a = a ^ (n - 2) where n = natVal (Proxy :: Proxy n) - fromRational r = error "cant transform" -- fromInteger (numerator r) / fromInteger (denominator r) + fromRational r = error "can't transform" -- fromInteger (numerator r) / fromInteger (denominator r) instance KnownNat n => Show (FieldElement n) where show (FieldElement a) | n == (2 ^ 256 - 2 ^ 32 - 977) = printf "0x%064x" a | otherwise = "FieldElement_" ++ show n ++ " " ++ show a where n = natVal (Proxy :: Proxy n) - -assert :: Bool -> Bool -assert False = error "WRONG" -assert x = x - -aa = - let a = FieldElement 2 :: FieldElement 31 - b = FieldElement 15 - in (a + b == FieldElement 17, a /= b, a - b == FieldElement 18) - -bb = - let a = FieldElement 19 :: FieldElement 31 - b = FieldElement 24 - in a * b - -- Elliptic curve data ECPoint a = Infinity @@ -61,7 +46,6 @@ data ECPoint a } deriving (Eq) - instance {-# OVERLAPPABLE #-} (PrintfArg a, Num a) => Show (ECPoint a) where show Infinity = "ECPoint(Infinity)" show p = printf "ECPoint(%f, %f)_%f_%f" (x p) (y p) (a p) (b p) @@ -112,6 +96,113 @@ instance (Eq a, Fractional a) => Semigroup (ECPoint a) where instance (Eq a, Fractional a) => Monoid (ECPoint a) where mempty = Infinity +-- The Bitcoin curve +type S256Field = FieldElement (2 ^ 256- 2^ 32 - 977) +type NField + = FieldElement + 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 +type S256Point = ECPoint S256Field + +s256point :: S256Field -> S256Field -> S256Point +s256point x y = + let p = ECPoint x y 0 7 + in if validECPoint p then p else error "Invalid point" + +ncons = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 +gcons = s256point + 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 + 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 + +-- ECDSA +data Signature = Signature + { r :: S256Field + , s :: NField + } + deriving Show + +asInt :: KnownNat n => FieldElement n -> Integer +asInt (FieldElement n) = n + +verifySignanture :: NField -> Signature -> S256Point -> Bool +verifySignanture z (Signature r s) pub = x target == r + where + target = + scalarProduct (asInt $ z / s) gcons + <> scalarProduct (asInt $ fromInteger (asInt r) / s) pub + +hash256 :: BS.ByteString -> BS.ByteString +hash256 = SHA256.hash . SHA256.hash + +fromBytes :: BS.ByteString -> Integer +fromBytes = BS.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b + +sighash :: BS.ByteString -> NField +sighash = fromInteger . fromBytes . hash256 + +integerToBytes :: Integer -> BS.ByteString +integerToBytes = BS.pack . go + where + go c = case c of + 0 -> [] + c -> go (c `div` 256) ++ [fromIntegral (c `mod` 256)] + +zeroPad :: Integer -> BS.ByteString -> BS.ByteString +zeroPad n s = BS.append padding s + where + padding = BS.pack (replicate (fromIntegral n - fromIntegral (BS.length s)) 0) + +toBytes32 :: Integer -> BS.ByteString +toBytes32 = zeroPad 32 . integerToBytes + +deterministicK :: NField -> NField -> NField +deterministicK (FieldElement priv) (FieldElement z) = fromInteger + $ candidate k2 v2 + where + k = BS.pack $ replicate 32 0 + v = BS.pack $ replicate 32 1 + zbs = toBytes32 z + skbs = toBytes32 priv + k1 = SHA256.hmac k $ v `BS.append` "\NUL" `BS.append` skbs `BS.append` zbs + v1 = SHA256.hmac k1 v + k2 = SHA256.hmac k1 $ v1 `BS.append` "\SOH" `BS.append` skbs `BS.append` zbs + v2 = SHA256.hmac k2 v1 + + candidate k v = + let vNew = SHA256.hmac k v + can = fromBytes vNew + in if can >= 1 && can < ncons + then can + else + let kp = SHA256.hmac k $ vNew `BS.append` "\NUL" + vp = SHA256.hmac kp vNew + in candidate kp vp + +signMessage :: NField -> BS.ByteString -> Signature +signMessage priv mesg = + let z = sighash mesg + k = deterministicK priv z + rm = scalarProduct (asInt k) gcons + FieldElement sm = (z + fromInteger (asInt (x rm)) * priv) / k + ss = if sm > div ncons 2 then ncons - sm else sm + in Signature (x rm) (fromInteger ss) + + +-- TESTs +-- Finite Fields +assert :: Bool -> Bool +assert False = error "WRONG" +assert x = x + +aa = + let a = FieldElement 2 :: FieldElement 31 + b = FieldElement 15 + in (a + b == FieldElement 17, a /= b, a - b == FieldElement 18) + +bb = + let a = FieldElement 19 :: FieldElement 31 + b = FieldElement 24 + in a * b +-- Elliptic curves tre = FieldElement 3 :: FieldElement 31 cc = let a = ECPoint tre (-7) 5 7 @@ -143,29 +234,14 @@ total = add aPoint $ add aPoint $ add aPoint $ add aPoint aPoint totalfold = foldr add Infinity $ replicate 5 aPoint totalmconcat = mconcat $ replicate 5 aPoint -type S256Field = FieldElement (2 ^ 256- 2^ 32 - 977) -type NField - = FieldElement - 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 -type S256Point = ECPoint S256Field -s256point :: S256Field -> S256Field -> S256Point -s256point x y = - let p = ECPoint x y 0 7 - in if validECPoint p then p else error "Invalid point" +-- Bitcoin curve li :: S256Field li = 12 ll :: ECPoint (FieldElement 31) ll = Infinity ri = ECPoint 3 7 5 7 :: S256Point - -ncons = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 -gcons = s256point - 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 - 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 - -asInt :: KnownNat n => FieldElement n -> Integer -asInt (FieldElement n) = n +-- ECDSA -- z = 0xbc62d4b80d9e36da29c16c5d4d9f11731f36052c72401a76c23c0fb5a9b74423 -- r = 0x37206a0610995c58074999cb9767b87af4c4978db68c06e8e6e81d282047a7c6 @@ -181,13 +257,15 @@ pub = s256point 0x887387e452b8eacc4acfde10d9aaf7f6d9a0f975aabb10d006e4da568744d06c 0x61de6d95231cd89026e286df3b6ae4a894a3378e393e93a0f45b666329a0ae34 -z1 = 0xec208baa0fc1c19f708a9ca96fdeff3ac3f230bb4a7ba4aede4942ad003c0f60 -r1 = 0xac8d1c87e51d0d441be8b3dd5b05c8795b48875dffe00b7ffcfac23010d3a395 +z1 = + 0xec208baa0fc1c19f708a9ca96fdeff3ac3f230bb4a7ba4aede4942ad003c0f60 :: NField +r1 = + 0xac8d1c87e51d0d441be8b3dd5b05c8795b48875dffe00b7ffcfac23010d3a395 :: S256Field s1 = 0x68342ceff8935ededd102dd876ffd6ba72d6a427a3edb13d26eb0781cb423c4 :: NField -signa1 = - scalarProduct (asInt $ z1 / s1) gcons <> scalarProduct (asInt $ r1 / s1) pub +--signa1 = + --scalarProduct (asInt $ z1 / s1) gcons <> scalarProduct (asInt $ r1 / s1) pub z2 = 0x7c076ff316692a3d7eb3c3bb0f8b1488cf72e1afcd929e29307032997a838a3d :: NField @@ -195,80 +273,10 @@ r2 = 0xeff69ef2b1bd93a66ed5219add4fb51e11a840f404876325a1e8ffe0529a2c :: NField s2 = 0xc7207fee197d27c618aea621406f6bf5ef6fca38681d82b2f06fddbdce6feab6 :: NField - -data Signature = Signature - { r :: S256Field - , s :: NField - } deriving (Show) - -verifySignanture :: NField -> Signature -> S256Point -> Bool -verifySignanture z (Signature r s) pub = x target == r - where - target = - scalarProduct (asInt $ z / s) gcons - <> scalarProduct (asInt $ (fromIntegral (asInt r)) / s) pub - - -fromBytes :: BS.ByteString -> Integer -fromBytes = BS.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b - -integerToBytes :: Integer -> BS.ByteString -integerToBytes = BS.pack . go - where - go c = case c of - 0 -> [] - c -> go (c `div` 256) ++ [fromIntegral (c `mod` 256)] - -zeroPad :: Integer -> BS.ByteString -> BS.ByteString -zeroPad n s = BS.append padding s - where - padding = BS.pack (replicate (fromIntegral n - fromIntegral (BS.length s)) 0) - -toBytes32 :: Integer -> BS.ByteString -toBytes32 = zeroPad 32 . integerToBytes - -hash256 :: BS.ByteString -> BS.ByteString -hash256 = SHA256.hash . SHA256.hash - -sighash :: BS.ByteString -> NField -sighash = fromIntegral . fromBytes . hash256 - -- priv = fromIntegral $ fromBytes $ hash256 "my secret" :: NField priv = 12345 -mesg = fromIntegral $ fromBytes $ hash256 "Programming Bitcoin!" :: NField +mesg = sighash "Programming Bitcoin!" k = 1234567890 :: NField rm = scalarProduct (asInt k) gcons sm = (mesg + fromIntegral (asInt (x rm)) * priv) / k pubm = scalarProduct (asInt priv) gcons - -signMessage :: NField -> BS.ByteString -> Signature -signMessage priv mesg = - let z = sighash mesg - k = deterministicK priv z - rm = scalarProduct (asInt k) gcons - FieldElement sm = (z + fromIntegral (asInt (x rm)) * priv) / k - ss = if sm > (div ncons 2) then ncons - sm else sm - in Signature (x rm) (fromIntegral ss) - -deterministicK :: NField -> NField -> NField -deterministicK priv (FieldElement z) = fromInteger $ candidate k2 v2 - where - k = BS.pack $ replicate 32 0 - v = BS.pack $ replicate 32 1 - zbs = toBytes32 z - FieldElement sk = priv - skbs = toBytes32 sk - k1 = SHA256.hmac k $ v `BS.append` "\NUL" `BS.append` skbs `BS.append` zbs - v1 = SHA256.hmac k1 v - k2 = SHA256.hmac k1 $ v1 `BS.append` "\SOH" `BS.append` skbs `BS.append` zbs - v2 = SHA256.hmac k2 v1 - - candidate k v = - let vNew = SHA256.hmac k v - can = fromBytes vNew - in if can >= 1 && can < ncons - then can - else - let kp = SHA256.hmac k $ vNew `BS.append` "\NUL" - vp = SHA256.hmac kp vNew - in candidate kp vp |