diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Version 0.1 + +* Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,219 @@ +Copyright 2020, Renzo Carbonara. + +Except where otherwise explicitly mentioned, all of contents of the +"bip32" project are licensed under the Apache License, +Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at the +end of this file or at http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + + +------------------------------------------------------------------------------- + + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# bip32 + +Haskell implementation of the BIP-0032 standard: Hierarchical Deterministic +Wallets, for Bitcoin and other cryptocurrencies. + +Based on the specification +at [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki). diff --git a/bip32.cabal b/bip32.cabal new file mode 100644 --- /dev/null +++ b/bip32.cabal @@ -0,0 +1,48 @@ +cabal-version: 2.4 +name: bip32 +version: 0.1 +license: Apache-2.0 +license-file: LICENSE +extra-source-files: README.md CHANGELOG.md +author: Renzo Carbonara +maintainer: renλren.zone +copyright: Copyright (c) Renzo Carbonara 2020 +category: Cryptography +build-type: Simple +synopsis: BIP-0032: Hierarchical Deterministic Wallets for Bitcoin and other cryptocurrencies +description: BIP-0032: Hierarchical Deterministic Wallets for Bitcoin and other cryptocurrencies +homepage: https://gitlab.com/k0001/hs-bip32 +bug-reports: https://gitlab.com/k0001/hs-bip32/issues +tested-with: GHC == 8.8.3, GHC == 8.6.5, GHCJS == 8.6.0 + +common basic + default-language: Haskell2010 + ghc-options: -O2 -Wall -Werror=incomplete-patterns + ghcjs-options: -O3 -Wall -Werror=incomplete-patterns + build-depends: base == 4.*, bytestring, base58-bytestring, binary + +library + import: basic + hs-source-dirs: lib + exposed-modules: BIP32 + if impl(ghcjs) + -- TODO + buildable: False + -- other-modules: BIP32.GHCJS + -- build-depends: ghcjs-base + else + other-modules: BIP32.GHC + build-depends: cryptonite, memory, secp256k1-haskell + +test-suite test + import: basic + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base16-bytestring, + hedgehog, + bip32, + tasty, + tasty-hedgehog, + tasty-hunit, diff --git a/lib/BIP32.hs b/lib/BIP32.hs new file mode 100644 --- /dev/null +++ b/lib/BIP32.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +-- | [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki) +-- Hierarchical Deterministic Wallets, for bitcoin and other cryptocurrencies. +module BIP32 + ( -- * Base58 serialization + encodeXPrv + , encodeXPub + , decodeXPrv + , decodeXPub + , decode + + -- * Raw serialization + , encodeXPrvRaw + , encodeXPubRaw + , decodeXPrvRaw + , decodeXPubRaw + , decodeRaw + + -- * Private key + , XPrv(..) + , xprvToXPub + , I.Prv + , I.prv + , I.unPrv + , I.prvToPub + + -- * Public key + , XPub(..) + , I.Pub + , I.pub + , I.unPub + + -- * Chain code + , Chain + , chain + , unChain + + -- * Derivation path + , Index(..) + , indexIsHardened + + -- * Subkeys + , subXPubXPub + , subXPrvXPrv + , subXPrvXPub + -- ** Bare + , subPubPub + , subPrvPrv + , subPrvPub + + -- * Depth + , Depth(..) + + -- * Fingerprint + , Fingerprint(..) + , fingerprint + + -- * Version + , Version(..) + -- ** Example versions + , version_xprv + , version_xpub + , version_tprv + , version_tpub + , version_Ltpv + , version_Ltub + , version_ttpv + , version_ttub + ) where + +import Control.Applicative +import Control.Monad +import Data.Bits +import qualified Data.Binary.Get as Bin +import qualified Data.ByteString as B +import qualified Data.ByteString.Base58 as B58 +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import Data.Word + + +#ifdef ghcjs_HOST_OS +import qualified BIP32.GHCJS as I +#else +import qualified BIP32.GHC as I +#endif + +-------------------------------------------------------------------------------- + +-- | Extended private key. +data XPrv = XPrv !Version !Depth !Fingerprint !Index !Chain !I.Prv + deriving (Eq, Show) + +-- | Obtain the 'XPub' corresponding to a particular 'XPrv', at a particular +-- 'Version'. +xprvToXPub :: Version -> XPrv -> XPub +xprvToXPub v (XPrv _ d f i c prv) = XPub v d f i c (I.prvToPub prv) + +-------------------------------------------------------------------------------- + +-- | Extended private key. +data XPub = XPub !Version !Depth !Fingerprint !Index !Chain !I.Pub + deriving (Eq, Show) + +-------------------------------------------------------------------------------- + +-- | The 33-byte serialized contents of either 'I.Pub' or 'I.Prv'. +newtype Key = Key B.ByteString + +keyPub :: I.Pub -> Key +{-# INLINE keyPub #-} +keyPub = Key . I.unPub + +keyPrv :: I.Prv -> Key +{-# INLINE keyPrv #-} +keyPrv = Key . B.cons 0 . I.unPrv + +-------------------------------------------------------------------------------- + +-- | Version bytes. +newtype Version = Version { unVersion :: Word32 } + deriving (Eq, Show) + +-- | @0x0488ade4@, “xprv”, Bitcoin mainnet private. +version_xprv :: Version +version_xprv = Version 0x0488ade4 +{-# INLINE version_xprv #-} + +-- | @0x0488b21e@, “xpub”, Bitcoin mainnet public. +version_xpub :: Version +version_xpub = Version 0x0488b21e +{-# INLINE version_xpub #-} + +-- | @0x04358394@, “tprv”, Bitcoin testnet private. +version_tprv :: Version +version_tprv = Version 0x04358394 +{-# INLINE version_tprv #-} + +-- | @0x043587cf@, “tpub”, Bitcoin testnet public. +version_tpub :: Version +version_tpub = Version 0x043587cf +{-# INLINE version_tpub #-} + +-- | @0x019d9cfe@, “Ltpv”, Litecoin mainnet private. +version_Ltpv :: Version +version_Ltpv = Version 0x019d9cfe +{-# INLINE version_Ltpv #-} + +-- | @0x019da462@, “Ltub”, Litecoin mainnet public. +version_Ltub :: Version +version_Ltub = Version 0x019da462 +{-# INLINE version_Ltub #-} + +-- | @0x0436ef7d@, “ttpv”, Litecoin testnet private. +version_ttpv :: Version +version_ttpv = Version 0x0436ef7d +{-# INLINE version_ttpv #-} + +-- | @0x0436f6e1@, “ttub”, Litecoin testnet public. +version_ttub :: Version +version_ttub = Version 0x0436f6e1 +{-# INLINE version_ttub #-} + +-------------------------------------------------------------------------------- + +-- | Derivation path depth. +-- +-- * @0@ for master nodes — @m@ +-- +-- * @1@ for level-1 derived keys — @m\/0'@, or @m\/13@, or … +-- +-- * @2@ for level-2 derived keys — @m\/0'\/28@, or @m\/44'/0'@, or … +-- +-- * … up to @255@. +newtype Depth = Depth { unDepth :: Word8 } + deriving (Eq, Show) + +depthNext :: Depth -> Maybe Depth +{-# INLINE depthNext #-} +depthNext (Depth w) = do + guard (w /= 0xFF) + pure (Depth (w + 1)) + +-------------------------------------------------------------------------------- + +-- | 4-byte fingerprint of a 'I.Pub' key. +newtype Fingerprint = Fingerprint { unFingerprint :: Word32 } + deriving (Eq, Show) + +fingerprint :: I.Pub -> Fingerprint +{-# INLINE fingerprint #-} +fingerprint = fingerprint' . keyId + +fingerprint' :: KeyId -> Fingerprint +{-# INLINE fingerprint' #-} +fingerprint' (KeyId x) = + let b = B.take 4 x :: B.ByteString + in Fingerprint $! unsafeShiftL (fromIntegral (B.index b 0)) 24 .|. + unsafeShiftL (fromIntegral (B.index b 1)) 16 .|. + unsafeShiftL (fromIntegral (B.index b 2)) 8 .|. + fromIntegral (B.index b 3) + +-------------------------------------------------------------------------------- + +-- | 20-byte key identifier. +newtype KeyId = KeyId B.ByteString + +keyId :: I.Pub -> KeyId +{-# INLINE keyId #-} +keyId = KeyId . I.ripemd160 . I.sha256 . I.unPub + +-------------------------------------------------------------------------------- + +-- | Chain code. +-- +-- Construct with 'chain'. +newtype Chain = Chain B.ByteString + deriving (Eq) + +instance Show Chain where + showsPrec n (Chain b) = showParen (n > 10) $ + showString "Chain " . + showsPrec 0 (BB.toLazyByteString (BB.byteStringHex b)) + +-- | Construct a 'Chain' code. +-- +-- See Bitcoin's [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki) +-- for details. +-- +-- 'Nothing' if the 'B.ByteString' length is not 32. +chain :: B.ByteString -> Maybe Chain +{-# INLINE chain #-} +chain x = do + guard (B.length x == 32) + Just (Chain x) + +-- | Obtain the 32 raw bytes inside a 'Chain'. +unChain :: Chain -> B.ByteString +{-# INLINE unChain #-} +unChain (Chain x) = x + +-------------------------------------------------------------------------------- + +-- | A derivation path 'Index'. +newtype Index = Index Word32 + deriving (Eq, Ord, Show) + +-- | Whether a derivation path 'Index' is hardened. That is, \(2^{31}\) or +-- larger. +indexIsHardened :: Index -> Bool +{-# INLINE indexIsHardened #-} +indexIsHardened (Index w) = w >= 0x80000000 + +-------------------------------------------------------------------------------- + +-- | Derive a child 'XPrv' subkey from a parent a parent 'XPrv' key. +-- +-- Returns 'Nothing' if the given inputs result in an invalid key. +subXPrvXPrv :: XPrv -> Index -> Maybe XPrv +subXPrvXPrv (XPrv v d0 _ _ ch0 prv0) i1 = do + d1 <- depthNext d0 + (ch1, prv1) <- subPrvPrv ch0 prv0 i1 + let f1 = fingerprint (I.prvToPub prv0) + pure $ XPrv v d1 f1 i1 ch1 prv1 + +-- | Derive a child 'XPub' subkey from a parent a parent 'XPub' key. +-- +-- The given 'Index' is expected to /not/ be hardened. +-- +-- Returns 'Nothing' if the given inputs result in an invalid key. +subXPubXPub :: XPub -> Index -> Maybe XPub +subXPubXPub (XPub v d0 _ _ ch0 pub0) i1 = do + d1 <- depthNext d0 + (ch1, pub1) <- subPubPub ch0 pub0 i1 + let f1 = fingerprint pub0 + pure $ XPub v d1 f1 i1 ch1 pub1 + +-- | Derive a child 'XPub' subkey from a parent a parent 'XPrv' key. +-- +-- Notice that while @'subXPubXPub' ('xprvToXPub' v) xprv i@ will fail with a +-- hardened 'Index', @'subXPrvXPub' v xprv i@ may succeed. +-- +-- Returns 'Nothing' if the given inputs result in an invalid key. +subXPrvXPub :: Version -> XPrv -> Index -> Maybe XPub +subXPrvXPub v xprv i1 = xprvToXPub v <$> subXPrvXPrv xprv i1 + +-------------------------------------------------------------------------------- + +-- | Derive a child 'I.Prv' subkey and 'Chain' code at a particular 'Index' from +-- a parent 'I.Prv' and 'Chain' code. +-- +-- Returns 'Nothing' if the given inputs result in an invalid key. +subPrvPrv :: Chain -> I.Prv -> Index -> Maybe (Chain, I.Prv) +subPrvPrv (Chain ch0) prv0 i1@(Index i1w) = do + let pub0 = I.prvToPub prv0 + x = I.hmacSHA512 ch0 $ mconcat $ if indexIsHardened i1 + then [B.singleton 0, I.unPrv prv0, word32BE i1w] + else [I.unPub pub0, word32BE i1w] + (xl, xr) = B.splitAt 32 x + prv1 <- I.addPrvTweak prv0 =<< I.tweak xl + ch1 <- chain xr + pure (ch1, prv1) + +-- | Derive a child 'I.Pub' subkey and 'Chain' code at a particular 'Index' from +-- a parent 'I.Pub' and 'Chain' code. +-- +-- The given 'Index' is expected to /not/ be hardened. +-- +-- Returns 'Nothing' if the given inputs result in an invalid key. +subPubPub :: Chain -> I.Pub -> Index -> Maybe (Chain, I.Pub) +subPubPub (Chain ch0) pub0 i1@(Index i1w) = do + guard (not (indexIsHardened i1)) + let x = I.hmacSHA512 ch0 (I.unPub pub0 <> word32BE i1w) + (xl, xr) = B.splitAt 32 x + pub1 <- I.addPubTweak pub0 =<< I.tweak xl + ch1 <- chain xr + pure (ch1, pub1) + +-- | Derive a child 'I.Pub' subkey and 'Chain' code at a particular 'Index' from +-- a parent 'I.Prv' and 'Chain' code. +-- +-- Notice that while @'subPubPub' ('I.prvToPub' prv) i@ will fail with a +-- hardened 'Index', @'subPrvPub' prv i@ may succeed. +-- +-- Returns 'Nothing' if the given inputs result in an invalid key. +subPrvPub :: Chain -> I.Prv -> Index -> Maybe (Chain, I.Pub) +subPrvPub ch0 prv0 i1 = fmap I.prvToPub <$> subPrvPrv ch0 prv0 i1 + +-------------------------------------------------------------------------------- + +-- | Obtain the Base58 representation for an 'XPub'. +-- +-- It can be either 111 or 112 bytes in length, and when rendered as ASCII it +-- looks something like this: +-- +-- @ +-- xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8 +-- @ +encodeXPub :: XPub -> B.ByteString +{-# INLINE encodeXPub #-} +encodeXPub a = base58EncodeWithChecksum (encodeXPubRaw a) + +-- | Obtain the Base58 representation for an 'XPrv'. +-- +-- It can be either 111 or 112 bytes in length, and when rendered as ASCII it +-- looks something like this: +-- +-- @ +-- xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi +-- @ +encodeXPrv :: XPrv -> B.ByteString +{-# INLINE encodeXPrv #-} +encodeXPrv a = base58EncodeWithChecksum (encodeXPrvRaw a) + +base58EncodeWithChecksum :: B.ByteString -> B.ByteString +{-# INLINE base58EncodeWithChecksum #-} +base58EncodeWithChecksum a = + B58.encodeBase58 B58.bitcoinAlphabet (a <> checksum32 a) + +-------------------------------------------------------------------------------- + +-- | Encode the 78 raw 'XPub' bytes. +encodeXPubRaw :: XPub -> B.ByteString +{-# INLINE encodeXPubRaw #-} +encodeXPubRaw (XPub v d f i c p) = encodeRaw v d f i c (keyPub p) + +-- | Encode the 78 raw 'XPrv' bytes. +encodeXPrvRaw :: XPrv -> B.ByteString +{-# INLINE encodeXPrvRaw #-} +encodeXPrvRaw (XPrv v d f i c p) = encodeRaw v d f i c (keyPrv p) + +-- | Encode the 78 raw extended key bytes. +encodeRaw + :: Version -> Depth -> Fingerprint -> Index -> Chain -> Key -> B.ByteString +encodeRaw (Version v) (Depth d) (Fingerprint f) (Index i) (Chain c) (Key k) = + BL.toStrict $ BB.toLazyByteString $ + BB.word32BE v <> + BB.word8 d <> + BB.word32BE f <> + BB.word32BE i <> + BB.byteString c <> + BB.byteString k + +-------------------------------------------------------------------------------- + +-- | Decode the Base58-encoded 'XPub' representation. See 'encodeXPub'. +decodeXPub :: B.ByteString -> Maybe XPub +{-# INLINE decodeXPub #-} +decodeXPub = decodeXPubRaw <=< base58DecodeWithChecksum + +-- | Decode the Base58-encoded 'XPrv' representation. See 'encodeXPrv'. +decodeXPrv :: B.ByteString -> Maybe XPrv +{-# INLINE decodeXPrv #-} +decodeXPrv = decodeXPrvRaw <=< base58DecodeWithChecksum + +-- | Decode the Base58-encoded representation of either and 'XPub' or an 'XPub'. +decode :: B.ByteString -> Maybe (Either XPub XPrv) +{-# INLINE decode #-} +decode = decodeRaw <=< base58DecodeWithChecksum + +base58DecodeWithChecksum :: B.ByteString -> Maybe B.ByteString +{-# INLINE base58DecodeWithChecksum #-} +base58DecodeWithChecksum = \a -> do + b <- B58.decodeBase58 B58.bitcoinAlphabet a + guard (B.length b == 78 + 4) + let (raw, ch) = B.splitAt 78 b + guard (ch == checksum32 raw) + pure raw + +-------------------------------------------------------------------------------- + +-- | Decode the 78 raw 'XPub' bytes. +decodeXPubRaw :: B.ByteString -> Maybe XPub +{-# INLINE decodeXPubRaw #-} +decodeXPubRaw = either Just (\_ -> Nothing) <=< decodeRaw + +-- | Decode the 78 raw 'XPrv' bytes. +decodeXPrvRaw :: B.ByteString -> Maybe XPrv +{-# INLINE decodeXPrvRaw #-} +decodeXPrvRaw = either (\_ -> Nothing) Just <=< decodeRaw + +-- | Encode the 78 raw 'XPub' or 'XPrv' bytes. +decodeRaw :: B.ByteString -> Maybe (Either XPub XPrv) +decodeRaw = \b -> do + guard (B.length b == 78) + case Bin.runGetOrFail getX (BL.fromStrict b) of + Right (lo, 78, ex) | BL.null lo -> Just ex + _ -> Nothing + +getX :: Bin.Get (Either XPub XPrv) +getX = do + v <- Version <$> Bin.getWord32be + d <- Depth <$> Bin.getWord8 + f <- Fingerprint <$> Bin.getWord32be + i <- Index <$> Bin.getWord32be + c <- Chain <$> Bin.getByteString 32 + ek <- fmap Left getPub <|> fmap Right getPrv + pure $ case ek of + Left k -> Left (XPub v d f i c k) + Right k -> Right (XPrv v d f i c k) + +getPrv :: Bin.Get I.Prv +getPrv = do + 0 <- Bin.getWord8 + a <- Bin.getByteString 32 + case I.prv a of + Just b -> pure b + Nothing -> fail "Bad private key" + +getPub :: Bin.Get I.Pub +getPub = do + a <- Bin.getByteString 33 + case I.pub a of + Just b -> pure b + Nothing -> fail "Bad public key" + +-------------------------------------------------------------------------------- + +word32BE :: Word32 -> B.ByteString -- ^ 4 bytes. +{-# INLINE word32BE #-} +word32BE = BL.toStrict . BB.toLazyByteString . BB.word32BE + +checksum32 :: B.ByteString -> B.ByteString -- ^ 4 bytes. +{-# INLINE checksum32 #-} +checksum32 = B.take 4 . I.sha256 . I.sha256 diff --git a/lib/BIP32/GHC.hs b/lib/BIP32/GHC.hs new file mode 100644 --- /dev/null +++ b/lib/BIP32/GHC.hs @@ -0,0 +1,132 @@ +-- | Implementation to be used when compiled with GHC +module BIP32.GHC + ( Prv + , prv + , unPrv + , prvToPub + , addPrvTweak + + , Pub + , pub + , unPub + , addPubTweak + + , Tweak + , tweak + + , hmacSHA512 + , ripemd160 + , sha256 + ) where + +import Control.Monad +import qualified Crypto.Hash as Hash +import qualified Crypto.MAC.HMAC as HMAC +import qualified Crypto.Secp256k1 as K +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B + +-------------------------------------------------------------------------------- + +-- | Private key. +-- +-- Construct with 'prv'. +newtype Prv = Prv K.SecKey + deriving (Eq, Show) + +-- | Obtain the 32 raw bytes inside a 'Prv'. See 'prv'. +unPrv :: Prv -> B.ByteString +{-# INLINE unPrv #-} +unPrv (Prv x) = K.getSecKey x + +-- | Construct a 'Prv' key from its raw bytes. +-- +-- * 32 bytes containing \(ser_{256}(k)\). +-- +-- See Bitcoin's [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki) +-- for details. +-- +-- 'Nothing' if something is not satisfied. +prv :: B.ByteString -> Maybe Prv +{-# INLINE prv #-} +prv x = Prv <$> K.secKey x + +-- | Obtain the 'Pub' key for 'Prv'. +prvToPub :: Prv -> Pub +{-# INLINE prvToPub #-} +prvToPub (Prv x) = Pub (K.derivePubKey x) + +-- | Tweak a 'Prv'ate key by adding 'Tweak' times the generator to it. +addPrvTweak :: Prv -> Tweak -> Maybe Prv +{-# INLINE addPrvTweak #-} +addPrvTweak (Prv p) (Tweak t) = Prv <$> K.tweakAddSecKey p t + +-------------------------------------------------------------------------------- + +-- | Public key. +-- +-- Construct with 'pub'. +newtype Pub = Pub K.PubKey + deriving (Eq, Show) + +-- | Obtain the 33 raw bytes inside a 'Pub'. See 'pub'. +-- +-- Corresponds to BIP-0032's \(ser_{P}(P)\). +unPub :: Pub -> B.ByteString +{-# INLINE unPub #-} +unPub (Pub x) = K.exportPubKey True x + +-- | Construct a 'Pub' key from its raw bytes. +-- +-- * 33 bytes in total, containing \(ser_{P}(P)\). +-- +-- * The leftmost byte is either @0x02@ or @0x03@, depending on the parity +-- of the omitted @y@ coordinate. +-- +-- * The remaining 32 bytes are \(ser_{256}(x)\). +-- +-- See Bitcoin's [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki) +-- for details. +-- +-- 'Nothing' if something is not satisfied. +pub :: B.ByteString -> Maybe Pub +{-# INLINE pub #-} +pub x = do + guard (B.length x == 33) + Pub <$> K.importPubKey x + +-- | Tweak a 'Pub'lic key by adding 'Tweak' times the generator to it. +addPubTweak :: Pub -> Tweak -> Maybe Pub +{-# INLINE addPubTweak #-} +addPubTweak (Pub p) (Tweak t) = Pub <$> K.tweakAddPubKey p t + +-------------------------------------------------------------------------------- + +newtype Tweak = Tweak K.Tweak + +-- | Convert a 32-Byte 'B.ByteString' to a 'Tweak'. +tweak :: B.ByteString -> Maybe Tweak +{-# INLINE tweak #-} +tweak x = Tweak <$> K.tweak x + +-------------------------------------------------------------------------------- + +hmacSHA512 + :: B.ByteString -- ^ Key. + -> B.ByteString -- ^ Data to hash. + -> B.ByteString -- ^ 64-byte long digest. +{-# INLINE hmacSHA512 #-} +hmacSHA512 k d = BA.convert (HMAC.hmac k d :: HMAC.HMAC Hash.SHA512) + +ripemd160 + :: B.ByteString -- ^ Data to hash. + -> B.ByteString -- ^ 20-byte long digest. +{-# INLINE ripemd160 #-} +ripemd160 d = BA.convert (Hash.hash d :: Hash.Digest Hash.RIPEMD160) + +sha256 + :: B.ByteString -- ^ Data to hash. + -> B.ByteString -- ^ 32-byte long digest. +{-# INLINE sha256 #-} +sha256 d = BA.convert (Hash.hash d :: Hash.Digest Hash.SHA256) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module Main (main) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base58 as B58 +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import Data.Foldable +import Data.Maybe (isJust) +import Data.Word +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Runners as Tasty +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), (@=?)) +import Test.Tasty.Hedgehog (testProperty, HedgehogTestLimit(..)) +import Hedgehog (MonadGen, property, forAll, (===), diff) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import qualified BIP32 as S + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] $ Tasty.localOption (HedgehogTestLimit (Just 10000)) + $ tt + +tt :: TestTree +tt = testGroup "BIP32" + [ testCase "versions" $ do + -- https://bitcoin.stackexchange.com/questions/38878/how-does-the-bip32-version-bytes-convert-to-base58 + let sv = B.take 4 . B58.encodeBase58 B58.bitcoinAlphabet + . flip mappend (B.replicate 78 0x00) + . BL.toStrict . BB.toLazyByteString . BB.word32BE . S.unVersion + sv S.version_xprv @?= "xprv" + sv S.version_xpub @?= "xpub" + sv S.version_tprv @?= "tprv" + sv S.version_tpub @?= "tpub" + sv S.version_Ltpv @?= "Ltpv" + sv S.version_Ltub @?= "Ltub" + sv S.version_ttpv @?= "ttpv" + sv S.version_ttub @?= "ttub" + + , testProperty "encodeXPubRaw length" $ property $ do + xpub <- forAll genXPub + B.length (S.encodeXPubRaw xpub) === 78 + + , testProperty "encodeXPrvRaw length" $ property $ do + xprv <- forAll genXPrv + B.length (S.encodeXPrvRaw xprv) === 78 + + , testProperty "encodeXPub length" $ property $ do + xpub <- forAll genXPub + let xpubB = S.encodeXPub xpub + diff (B.length xpubB) (>=) 111 + diff (B.length xpubB) (<=) 112 + + , testProperty "encodeXPrv length" $ property $ do + xprv <- forAll genXPrv + let xprvB = S.encodeXPrv xprv + diff (B.length xprvB) (>=) 111 + diff (B.length xprvB) (<=) 112 + + , testProperty "XPub raw roundtrip" $ property $ do + xpub :: S.XPub <- forAll genXPub + let xpubB = S.encodeXPubRaw xpub + Just xpub === S.decodeXPubRaw xpubB + + , testProperty "XPrv raw roundtrip" $ property $ do + xprv :: S.XPrv <- forAll genXPrv + let xprvB = S.encodeXPrvRaw xprv + Just xprv === S.decodeXPrvRaw xprvB + + , testProperty "XPub Base58 roundtrip" $ property $ do + xpub :: S.XPub <- forAll genXPub + let xpubB = S.encodeXPub xpub + Just xpub === S.decodeXPub xpubB + + , testProperty "XPrv Base58 roundtrip" $ property $ do + xprv :: S.XPrv <- forAll genXPrv + let xprvB = S.encodeXPrv xprv + Just xprv === S.decodeXPrv xprvB + + , testCase "Pub invalid" $ do + Nothing @=? S.pub "\x03hxxqhlivzpapqhxguwpftplfduateosa" + + , testProperty "subPubPub with normal index" $ property $ do + S.XPub v d f i c p <- forAll genXPub + let d' = S.Depth $ case S.unDepth d of { 255 -> 254; w -> w } + xpub' = S.XPub v d' f i c p + i1n :: S.Index <- forAll genIndexNormal + True === isJust (S.subXPubXPub xpub' i1n) + + , testProperty "subPubPub with hardended index" $ property $ do + xpub :: S.XPub <- forAll genXPub + ih :: S.Index <- forAll genIndexHardened + Nothing === S.subXPubXPub xpub ih +{- + , testCase "subPubPub invalid" $ do + xpub = S.XPub (S.Version 0 + 97 ┃ xpub :: S.XPub <- forAll genXPub + ┃ │ XPub + ┃ │ Version { unVersion = 0 } + ┃ │ Depth { unDepth = 255 } + ┃ │ Fingerprint { unFingerprint = 0 } + ┃ │ (Index 0) + ┃ │ (Chain + ┃ │ "6161616161616161616161616161616161616161616161616161616161616161") + ┃ │ (Pub + ┃ │ "02616161616161616161616161616161616161616161687762686f616973786477") + 98 ┃ ih :: S.Index <- forAll genIndexNormal + ┃ │ Index 894862002 +-} + , tt_vectors + ] + +tt_vectors :: TestTree +tt_vectors = testGroup "Test vectors" + [ tv $ TV { tv_name = "m" + , tv_depth = 0 + , tv_fingerp = 0x00000000 + , tv_index = 0 + , tv_chain = "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508" + , tv_xpub = "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8" + , tv_pub = "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" + , tv_xprv = "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi" + , tv_prv = "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" + , tv_subPubPubs = [ (0, "xpub68Gmy5EVb2BdFbj2LpWrk1M7obNuaPTpT5oh9QCCo5sRfqSHVYWex97WpDZzszdzHzxXDAzPLVSwybe4uPYkSk4G3gnrPqqkV9RyNzAcNJ1") + , (1, "xpub68Gmy5EVb2BdHTYHpekwGdcbBWax19w9HwA2DaADYvuCSSgt4YAErxxSN1KWSnmyqkwRNbnTj3XiUBKmHeC8rTjLRPjSULcDKQQgfgJDppq") ] + , tv_subPrvPrvs = [ (0, "xprv9uHRZZhbkedL37eZEnyrNsQPFZYRAvjy5rt6M1nbEkLSo378x1CQQLo2xxBvREwiK6kqf7GRNvsNEchwibzXaV6i5GcsgyjBeRguXhKsi4R") + , (1, "xprv9uHRZZhbkedL4yTpidDvuVfrdUkTbhDHviERRBkbzbNDZeMjWzqzKAdxWhzftGDSxDmBdakjqHiZJbkwiaTEXJdjZAaAjMZEE3PMbMrPJih") + , (0 + 0x80000000, "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7") + , (1 + 0x80000000, "xprv9uHRZZhk6KAJFszJGW6LoUFq92uL7FvkBhmYiMurCWPHLJZkX2aGvNdRUBNnJu7nv36WnwCN59uNy6sxLDZvvNSgFz3TCCcKo7iutQzpg78") ] + } + , tv $ TV { tv_name = "m/0" + , tv_depth = 1 + , tv_fingerp = 0x3442193e + , tv_index = 0 + , tv_chain = "d323f1be5af39a2d2f08f5e8f664633849653dbe329802e9847cfc85f8d7b52a" + , tv_xpub = "xpub68Gmy5EVb2BdFbj2LpWrk1M7obNuaPTpT5oh9QCCo5sRfqSHVYWex97WpDZzszdzHzxXDAzPLVSwybe4uPYkSk4G3gnrPqqkV9RyNzAcNJ1" + , tv_pub = "027c4b09ffb985c298afe7e5813266cbfcb7780b480ac294b0b43dc21f2be3d13c" + , tv_xprv = "xprv9uHRZZhbkedL37eZEnyrNsQPFZYRAvjy5rt6M1nbEkLSo378x1CQQLo2xxBvREwiK6kqf7GRNvsNEchwibzXaV6i5GcsgyjBeRguXhKsi4R" + , tv_prv = "4e2cdcf2f14e802810e878cf9e6411fc4e712edf19a06bcfcc5d5572e489a3b7" + , tv_subPubPubs = [ (0, "xpub6AvUGrnEpfvJ8L7GLRkBTByQ9uBvUHp9o5VxHrFxhvzV4dSWkySpNaBoLR9FpbnwRmTa69yLHF3QfcaxbWT7gWdwws5k4dpmJvqpEuMWwnj") ] + , tv_subPrvPrvs = [ (0, "xprv9ww7sMFLzJMzur2oEQDB642fbsMS4q6JRraMVTrM9bTWBq7NDS8ZpmsKVB4YF3mZecqax1fjnsPF19xnsJNfRp4RSyexacULXMKowSACTRc") ] + } + + , tv $ TV { tv_name = "m/0'" + , tv_depth = 1 + , tv_fingerp = 0x3442193e + , tv_index = 0 + 0x80000000 + , tv_chain = "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141" + , tv_xpub = "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw" + , tv_pub = "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" + , tv_xprv = "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7" + , tv_prv = "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" + , tv_subPubPubs = [ (0, "xpub6ASuArnXKPbfEVRpCesNx4P939HDXENHkksgxsVG1yNp9958A33qYoPiTN9QrJmWFa2jNLdK84bWmyqTSPGtApP8P7nHUYwxHPhqmzUyeFG") ] + , tv_subPrvPrvs = [ (0, "xprv9wTYmMFdV23N21MM6dLNavSQV7Sj7meSPXx6AV5eTdqqGLjycVjb115Ec5LgRAXscPZgy5G4jQ9csyyZLN3PZLxoM1h3BoPuEJzsgeypdKj") + , (0 + 0x80000000, "xprv9wTYmMFmpgaLB5Hge4YtaGqCKpsYPTD9vXWSsmdZrNU3Y2i4WoBykm6ZteeCLCCZpGxdHQuqEhM6Gdo2X6CVrQiTw6AAneF9WSkA9ewaxtS") ] + } + , tv $ TV { tv_name = "m/44'/0'/0'/0" + , tv_depth = 4 + , tv_fingerp = 0x31bf9083 + , tv_index = 0 + , tv_chain = "6dd51cfd6f41ad9d1edf007727a683a2cd317524e43bf30b5cd1a2035c1041cf" + , tv_xpub = "xpub6Du7UxgPt9xyZsijCkstyy1MEuR6SZbAh3MaaE1yvKesdKSygQKqfYLzVxdhoPeRwwTLwpEnjzMqVMb5NYvazx56sxNCRoExGNY1VNMqsSD" + , tv_pub = "03073cdc669834931577d21319e4414523ce32a638b4ae42eb4ace8ed3dac683b5" + , tv_xprv = "xprv9zum5T9W3nQgMPeG6jLtcq4cgsac36sKKpRymqcNMz7tkX7q8s1b7k2WegNtWCo91gRjnSZANnsMGLhjsofsQfVtuSLQdfeH48gDNosBAHk" + , tv_prv = "65e96c73a30bcb815fc0f0a5694a0ead061034eba030d1b82991dff1f9b68519" + , tv_subPubPubs = [ (0, "xpub6FqQEmsqnmQYh8vkY8NsHUygAjSbfXCCXFzWYe2GHG3mL4ng9Ned6kEKHN4LpNQW3CwZAsnfgoj7VcqrbXoXiAUXz1bZdsam9QzP9RWjR2u") ] + , tv_subPrvPrvs = [ (0, "xprvA2r3qGLwxPrFUerHS6qrvM2wchc7G4UMA34ukFceivWnTGTXbqLNYwuqS8nkbm7SjvgNSiHumkYLur27kjdnGZexAtiC6Ha4SNr7Wpeoz2V") ] + } + ] + +data TV = TV + { tv_name :: String + , tv_depth :: Word8 + , tv_fingerp :: Word32 + , tv_index :: Word32 + , tv_chain :: B.ByteString -- ^ Expected chain code in lower-case hexadecimal + , tv_xpub :: B.ByteString -- ^ Base58-serialized XPub + , tv_pub :: B.ByteString -- ^ Expected public key in lower-case hexadecimal + , tv_xprv :: B.ByteString -- ^ Base58-serialized XPrv + , tv_prv :: B.ByteString -- ^ Expected private key in lower-case hexadecimal + , tv_subPubPubs :: [(Word32, B.ByteString)] -- ^ Pub->Pub Base58 subkeys with index + , tv_subPrvPrvs :: [(Word32, B.ByteString)] -- ^ Prv->Prv Base58 subkeys with index + } + + +tv :: TV -> TestTree +tv x = testGroup (tv_name x) + [ testCase "chain" $ do + Just (tv_chain x) @=? fmap (toBase16 . S.unChain) + (S.chain (fromBase16 (tv_chain x))) + + , testCase "prv" $ do + Just (tv_prv x) @=? fmap (toBase16 . S.unPrv) + (S.prv (fromBase16 (tv_prv x))) + + , testCase "pub" $ do + Just (tv_pub x) @=? fmap (toBase16 . S.unPub) + (S.pub (fromBase16 (tv_pub x))) + + , testCase "xprvToXPub" $ do + let Just xprv = S.decodeXPrv (tv_xprv x) + Just xpub = S.decodeXPub (tv_xpub x) + xpub @=? S.xprvToXPub S.version_xpub xprv + + , testCase "xprv" $ do + Just xprv@(S.XPrv v d f i c k) <- pure $ S.decodeXPrv (tv_xprv x) + S.encodeXPrv xprv @?= tv_xprv x + v @?= S.version_xprv + d @?= S.Depth (tv_depth x) + f @?= S.Fingerprint (tv_fingerp x) + i @?= S.Index (tv_index x) + Just c @?= S.chain (fromBase16 ((tv_chain x))) + Just k @?= S.prv (fromBase16 (tv_prv x)) + + , testCase "xpub" $ do + Just xpub@(S.XPub v d f i c k) <- pure $ S.decodeXPub (tv_xpub x) + S.encodeXPub xpub @?= tv_xpub x + v @?= S.version_xpub + d @?= S.Depth (tv_depth x) + f @?= S.Fingerprint (tv_fingerp x) + i @?= S.Index (tv_index x) + Just c @?= S.chain (fromBase16 ((tv_chain x))) + Just k @?= S.pub (fromBase16 (tv_pub x)) + + , testCase "subPubPub" $ do + let Just xpub0@(S.XPub v0 d0 _ _ _ _) = S.decodeXPub (tv_xpub x) + for_ (tv_subPubPubs x) $ \(i1w, xpub1B) -> do + let i1 = S.Index i1w + Just xpub1@(S.XPub v1 d1 _ i1' _ _) = S.subXPubXPub xpub0 i1 + v1 @?= v0 + d1 @?= S.Depth (1 + S.unDepth d0) + i1' @?= i1 + S.encodeXPub xpub1 @?= xpub1B + + , testCase "subPrvPrv" $ do + let Just xprv0@(S.XPrv v0 d0 _ _ _ _) = S.decodeXPrv (tv_xprv x) + for_ (tv_subPrvPrvs x) $ \(i1w, xprv1B) -> do + let i1 = S.Index i1w + Just xprv1@(S.XPrv v1 d1 _ i1' _ _) = S.subXPrvXPrv xprv0 i1 + v1 @?= v0 + d1 @?= S.Depth (1 + S.unDepth d0) + i1' @?= i1 + S.encodeXPrv xprv1 @?= xprv1B + ] + +-------------------------------------------------------------------------------- + +genIndex :: MonadGen m => m S.Index +genIndex = S.Index <$> Gen.word32 Range.constantBounded + +genIndexNormal :: MonadGen m => m S.Index +genIndexNormal = S.Index <$> Gen.word32 (Range.constant 0 (0x80000000 - 1)) + +genIndexHardened :: MonadGen m => m S.Index +genIndexHardened = S.Index <$> Gen.word32 (Range.constant 0x80000000 maxBound) + +genXPub :: MonadGen m => m S.XPub +genXPub = S.XPub <$> genVersion + <*> genDepth <*> genFingerprint + <*> genIndex <*> genChain <*> genPub + +genXPrv :: MonadGen m => m S.XPrv +genXPrv = S.XPrv <$> genVersion + <*> genDepth <*> genFingerprint + <*> genIndex <*> genChain <*> genPrv + +genVersion :: MonadGen m => m S.Version +genVersion = S.Version <$> Gen.word32 Range.constantBounded + +genFingerprint :: MonadGen m => m S.Fingerprint +genFingerprint = S.Fingerprint <$> Gen.word32 Range.constantBounded + +genDepth :: MonadGen m => m S.Depth +genDepth = S.Depth <$> Gen.word8 Range.constantBounded + +genChain :: MonadGen m => m S.Chain +genChain = do + b <- Gen.bytes (Range.singleton 32) + let Just c = S.chain b + pure c + +genPrv :: MonadGen m => m S.Prv +genPrv = do + b <- Gen.bytes (Range.singleton 32) + let Just k = S.prv b + pure k + +genPub :: MonadGen m => m S.Pub +genPub = do + h <- Gen.element [2, 3 :: Word8] + b <- Gen.bytes (Range.singleton 32) + case S.pub (B.cons h b) of + Just k -> pure k + Nothing -> genPub + +-------------------------------------------------------------------------------- + +toBase16 :: B.ByteString -> B.ByteString +toBase16 = B16.encode + +fromBase16 :: B.ByteString -> B.ByteString +fromBase16 a = case B16.decode a of + (b, "") -> b + _ -> error ("Invalid base16 string: " <> show a) + +