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 +"bitcoin-address" 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,5 @@ +# bitcoin-address + +Bitcoin address generation and rendering. Parsing coming soon. + +This library builds on GHC and GHCJS. diff --git a/bitcoin-address.cabal b/bitcoin-address.cabal new file mode 100644 --- /dev/null +++ b/bitcoin-address.cabal @@ -0,0 +1,64 @@ +cabal-version: 2.4 +name: bitcoin-address +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: Bitcoin address generation and rendering. Parsing coming soon. +description: + Bitcoin address generation and rendering. Parsing coming soon. + . + This library builds in GHC and GHCJS. +homepage: https://gitlab.com/k0001/hs-bitcoin-address +bug-reports: https://gitlab.com/k0001/hs-bitcoin-address/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.*, + bitcoin-keys, + bitcoin-script, + bytestring, + default-extensions: + DerivingStrategies + GeneralizedNewtypeDeriving + LambdaCase + OverloadedStrings + +library + import: basic + hs-source-dirs: lib + exposed-modules: + Bitcoin.Address + Bitcoin.Address.Hash + Bitcoin.Address.Internal + Bitcoin.Address.Settings + Bitcoin.Address.Script + Bitcoin.Address.SegWit + build-depends: + base58-bytestring, + bech32, + binary, + bitcoin-hash, + text, + +test-suite test + import: basic + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base16-bytestring, + hedgehog, + bitcoin-address, + tasty, + tasty-hedgehog, + tasty-hunit, diff --git a/lib/Bitcoin/Address.hs b/lib/Bitcoin/Address.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Address.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE StrictData #-} + +-- | Bitcoin address generation and rendering. Parsing is comming soon. +-- +-- Most of what you'll normally need for safely dealing with Bitcoin addresses +-- is exported from this module. +module Bitcoin.Address + ( -- * Network settings + btc + , btcTestnet + + -- * Addresses + , Address(..) + , renderAddress + , addressScript + -- ** P2PKH + , p2pkh + -- ** P2SH + , p2sh + , p2sh_multiSig + , p2sh_p2wpkh + , p2sh_p2wsh + , p2sh_p2wsh_multiSig + -- ** SegWit P2WPKH + , p2wpkh + -- ** SegWit P2WSH + , p2wsh + , p2wsh_multiSig + ) where + +import Bitcoin.Keys (Pub) +import Bitcoin.Hash (check32) +import qualified Data.Bitcoin.Script as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Base58 as B58 + +import Bitcoin.Address.Hash +import qualified Bitcoin.Address.Script as XS +import qualified Bitcoin.Address.SegWit as SW +import Bitcoin.Address.Settings + +-------------------------------------------------------------------------------- + +-- | A Bitcoin compatible address. +-- +-- These constructors are safe to use. However, you may find the similarly +-- named helper functions in "Bitcoin.Address" more practical. +data Address + = P2PKH PrefixP2PKH PubHash160 + -- ^ A “pay to public-key hash” address. See 'p2pkh'. + | P2SH PrefixP2SH ScriptHash160 + -- ^ A “pay to script hash” address. See 'p2sh', 'p2sh_multiSig', + -- 'p2sh_p2wpkh', 'p2sh_p2wsh_multiSig'. + | SegWit PrefixSegWit SW.Program + -- ^ A native SegWit address. See 'p2wpkh', 'p2wsh', 'p2wsh_multiSig'. + deriving (Eq, Ord) + +-- | As 'renderAddress'. +instance Show Address where + show = B8.unpack . renderAddress + +-------------------------------------------------------------------------------- +-- P2PKH + +-- | 'P2PKH' 'Address' for a 'Pub'lic key. +-- +-- This is the address format associated with BIP-0032 +-- derivation path @m\/44'\/0'@ +p2pkh :: Settings -> Pub -> Address +p2pkh sett = P2PKH (settings_prefixP2PKH sett) . pubHash160 + +-------------------------------------------------------------------------------- +-- P2SH + +-- | 'P2SH' 'Address' for a 'S.Script'. +-- +-- See 'p2sh_p2wpkh', 'p2sh_p2wpkh' or 'p2sh_p2wsh_multiSig' for some of +-- the typical constructions using 'p2sh'. It's unlikely that you'll need to use +-- 'p2sh' directly unless you are deploying a non-standard 'S.Script'. +p2sh :: Settings -> S.Script -> Address +p2sh sett = P2SH (settings_prefixP2SH sett) . scriptHash160 + +-- | 'P2SH' “P2WPKH-in-'P2SH'” 'Address' for a 'Pub'lic key. +-- +-- This is the address format associated with BIP-0032 +-- derivation path @m\/49'\/0'@ +p2sh_p2wpkh :: Settings -> Pub -> Address +p2sh_p2wpkh sett = p2sh sett . XS.segWit . SW.p2wpkh . pubHash160 + +-- | 'P2SH' 'Address' for a standard m-of-n 'XS.multiSig' 'S.Script'. +p2sh_multiSig + :: Settings + -> [Pub] -- ^ Public keys. Total number in range [1 … 16] + -> Int -- ^ Required number of signatures in range [1 … 16] + -> Maybe Address -- ^ 'Nothing' if any of the inputs is invalid. +p2sh_multiSig sett pks req = p2sh sett <$> XS.multiSig pks req + +-- | 'P2SH' “P2WSH-in-'P2SH'” 'Address' for a 'S.Script'. +-- +-- __WARNING__ SegWit does not support uncompressed SEC 'Pub'lic addresses +-- (i.e., 'Bitcoin.Keys.pubUncompressed' and 'pubUncompressedHash160'), so be +-- sure to only mention compressed SEC 'Pub'lic addresses in your 'S.Script's +-- (i.e., 'Bitcoin.Keys.pubCompressed' and 'pubHash160'). +p2sh_p2wsh :: Settings -> S.Script -> Address +p2sh_p2wsh sett = p2sh sett . XS.segWit . SW.p2wsh . scriptSHA256 + +-- | 'P2SH' “P2WSH-in-'P2SH'” 'Address' for a standard m-of-n 'XS.multiSig' +-- 'S.Script'. +p2sh_p2wsh_multiSig + :: Settings + -> [Pub] -- ^ Public keys. Total number in range [1 … 16] + -> Int -- ^ Required number of signatures in range [1 … 16] + -> Maybe Address -- ^ 'Nothing' if any of the inputs is invalid. +p2sh_p2wsh_multiSig sett pks req = p2sh_p2wsh sett <$> XS.multiSig pks req + +-------------------------------------------------------------------------------- +-- SegWit + +-- | 'SegWit' “P2WPKH” 'Address' for a 'Pub'lic key. +-- +-- This is the address format associated with BIP-0032 +-- derivation path @m\/84'\/0'@ +p2wpkh :: Settings -> Pub -> Address +p2wpkh sett = SegWit (settings_prefixSegWit sett) . SW.p2wpkh . pubHash160 + +-- | 'SegWit' “P2WSH” 'Address' for a 'S.Script'. +-- +-- Please see 'p2wsh_multiSig' for some of the typical constructions using +-- 'p2wsh'. It's unlikely that you'll need to use 'p2wsh' directly unless you +-- are deploying a non-standard 'S.Script'. +-- +-- __WARNING__ SegWit does not support uncompressed SEC 'Pub'lic addresses +-- (i.e., 'Bitcoin.Keys.pubUncompressed' and 'pubUncompressedHash160'), so be +-- sure to only mention compressed SEC 'Pub'lic addresses in your 'S.Script's +-- (i.e., 'Bitcoin.Keys.pubCompressed' and 'pubHash160'). +p2wsh :: Settings -> S.Script -> Address +p2wsh sett = SegWit (settings_prefixSegWit sett) . SW.p2wsh . scriptSHA256 + +-- | 'SegWit' “P2WSH” 'Address' for a standard m-of-n 'XS.multiSig' 'S.Script'. +p2wsh_multiSig + :: Settings + -> [Pub] -- ^ Public keys. Total number in range [1 … 16] + -> Int -- ^ Required number of signatures in range [1 … 16] + -> Maybe Address -- ^ 'Nothing' if any of the inputs is invalid. +p2wsh_multiSig sett pks req = p2wsh sett <$> XS.multiSig pks req + +-------------------------------------------------------------------------------- + +-- | Obtain the 'S.Script' associated with a particular 'Address'. +-- +-- This will be one of 'XS.p2pkh', 'XS.p2sh' or 'XS.segWit' from +-- the "Bitcoin.Address.Script" module. +addressScript :: Address -> S.Script +addressScript = \case + P2PKH _ pkh -> XS.p2pkh pkh + P2SH _ sh -> XS.p2sh sh + SegWit _ swp -> XS.segWit swp + +-------------------------------------------------------------------------------- +{- +fromBase58Check :: B.ByteString -> Maybe B.ByteString +fromBase58Check a = do + b <- B58.decodeBase58 B58.bitcoinAlphabet a + guard (B.length b >= 4) + let (x, ch) = B.splitAt (B.length b - 4) b + guard (check32 x == ch) + pure x +-} +-------------------------------------------------------------------------------- + +-- | Render and 'Address' to its human readable form. +renderAddress :: Address -> B.ByteString +renderAddress = \case + P2PKH pre pkh -> toBase58Check $ B.cons (unPrefixP2PKH pre) (unPubHash160 pkh) + P2SH pre sh -> toBase58Check $ B.cons (unPrefixP2SH pre) (unScriptHash160 sh) + SegWit pre swp -> SW.renderProgram pre swp + +-------------------------------------------------------------------------------- + +toBase58Check :: B.ByteString -> B.ByteString +{-# INLINE toBase58Check #-} +toBase58Check a = B58.encodeBase58 B58.bitcoinAlphabet (a <> check32 a) + +-------------------------------------------------------------------------------- + +-- | BTC /mainnet/ network settings. +-- +-- * 'P2PKH' addresses, when rendered, start with __1__. +-- +-- * 'P2SH' addresses, when rendered, start with __3__. +-- +-- * 'SegWit' addresses, when rendered, start with __bc1__. +btc :: Settings +btc = Settings btc_prefixP2PKH btc_prefixP2SH btc_prefixSegWit + +btc_prefixP2PKH :: PrefixP2PKH +btc_prefixP2PKH = PrefixP2PKH 0x00 + +btc_prefixP2SH :: PrefixP2SH +btc_prefixP2SH = PrefixP2SH 0x05 + +btc_prefixSegWit :: PrefixSegWit +Just btc_prefixSegWit = prefixSegWit "bc" + +-------------------------------------------------------------------------------- + +-- | BTC /testnet/ network settings. +-- +-- * 'P2PKH' addresses, when rendered, start with __m__ or __n__. +-- +-- * 'P2SH' addresses, when rendered, start with __2__. +-- +-- * 'SegWit' addresses, when rendered, start with __tb1__. +btcTestnet :: Settings +btcTestnet = Settings btcTestnet_prefixP2PKH btcTestnet_prefixP2SH + btcTestnet_prefixSegWit + +btcTestnet_prefixP2PKH :: PrefixP2PKH +btcTestnet_prefixP2PKH = PrefixP2PKH 0x6f + +btcTestnet_prefixP2SH :: PrefixP2SH +btcTestnet_prefixP2SH = PrefixP2SH 0xc4 + +btcTestnet_prefixSegWit :: PrefixSegWit +Just btcTestnet_prefixSegWit = prefixSegWit "tb" + diff --git a/lib/Bitcoin/Address/Hash.hs b/lib/Bitcoin/Address/Hash.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Address/Hash.hs @@ -0,0 +1,134 @@ +-- | This module exports hash constructions used by Bitcoin addresses. +module Bitcoin.Address.Hash + ( -- * PubHash160 + PubHash160 + , unPubHash160 + , parsePubHash160 + , pubHash160 + , pubUncompressedHash160 + + -- * ScriptHash160 + , ScriptHash160 + , unScriptHash160 + , parseScriptHash160 + , scriptHash160 + + -- * ScriptSHA256 + , ScriptSHA256 + , unScriptSHA256 + , parseScriptSHA256 + , scriptSHA256 + ) where + +import Bitcoin.Keys (Pub, pubCompressed, pubUncompressed) +import Bitcoin.Hash (hash160) +import Bitcoin.Hash.Prim (sha256) +import Control.Monad +import qualified Data.Bitcoin.Script as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy.Char8 as BL8 + +import Bitcoin.Address.Internal (scriptBytes) + +-------------------------------------------------------------------------------- + +-- | The 'hash160' of a 'Pub'lic key. +newtype PubHash160 = PubHash160 B.ByteString + deriving newtype (Eq, Ord) + +-- | Base-16 encoded. +instance Show PubHash160 where + showsPrec n (PubHash160 b) = showParen (n > 10) $ + showString "PubHash160 " . + mappend (BL8.unpack (BB.toLazyByteString (BB.byteStringHex b))) + +-- | Get the 20 bytes in 'PubHash160'. +unPubHash160 :: PubHash160 -> B.ByteString +{-# INLINE unPubHash160 #-} +unPubHash160 (PubHash160 x) = x + +-- | Create a 'PubHash160' from its 20 raw bytes. +parsePubHash160 :: B.ByteString -> Maybe PubHash160 +{-# INLINE parsePubHash160 #-} +parsePubHash160 b = do + guard (B.length b == 20) + pure (PubHash160 b) + +-- | The 'hash160' of the compressed SEC representation of a 'Pub'lic key. +-- +-- Usually, __this is what you want__. +pubHash160 :: Pub -> PubHash160 +{-# INLINE pubHash160 #-} +pubHash160 = PubHash160 . hash160 . pubCompressed + +-- | The 'hash160' of the uncompressed SEC representation of a 'Pub'lic key. +-- +-- It's very unlikely that you want this. Except if it's ten years ago or you +-- are dealing with very old addresses. +-- +-- __WARNING__ do not use this with SegWit addresses 'Bitcoin.Address.P2WPKH', +-- or in 'Bitcoin.Address.P2WSH' 'S.Script's. +pubUncompressedHash160 :: Pub -> PubHash160 +{-# INLINE pubUncompressedHash160 #-} +pubUncompressedHash160 = PubHash160 . hash160 . pubUncompressed + +-------------------------------------------------------------------------------- + +-- | The 'hash160' of a 'S.Script' as required by 'Bitcoin.Address.P2SH'. +newtype ScriptHash160 = ScriptHash160 B.ByteString + deriving newtype (Eq, Ord) + +-- | Base-16 encoded. +instance Show ScriptHash160 where + showsPrec n (ScriptHash160 b) = showParen (n > 10) $ + showString "ScriptHash160 " . + mappend (BL8.unpack (BB.toLazyByteString (BB.byteStringHex b))) + +-- | Get the 20 bytes in 'ScriptHash160'. +unScriptHash160 :: ScriptHash160 -> B.ByteString +{-# INLINE unScriptHash160 #-} +unScriptHash160 (ScriptHash160 x) = x + +-- | Create a 'ScriptHash160' from its 20 raw bytes. +parseScriptHash160 :: B.ByteString -> Maybe ScriptHash160 +{-# INLINE parseScriptHash160 #-} +parseScriptHash160 b = do + guard (B.length b == 20) + pure (ScriptHash160 b) + +-- | Hash a 'S.Script' as required by 'Bitcoin.Address.P2SH'. +scriptHash160 :: S.Script -> ScriptHash160 +{-# INLINE scriptHash160 #-} +scriptHash160 = ScriptHash160 . hash160 . scriptBytes + +-------------------------------------------------------------------------------- + +-- | The 'sha256' of a 'S.Script' as required by 'Bitcoin.Address.P2WSH'. +newtype ScriptSHA256 = ScriptSHA256 B.ByteString + deriving newtype (Eq, Ord) + +-- | Base-16 encoded. +instance Show ScriptSHA256 where + showsPrec n (ScriptSHA256 b) = showParen (n > 10) $ + showString "ScriptSHA256 " . + mappend (BL8.unpack (BB.toLazyByteString (BB.byteStringHex b))) + +-- | Get the 32 bytes in 'ScriptSHA256'. +unScriptSHA256 :: ScriptSHA256 -> B.ByteString +{-# INLINE unScriptSHA256 #-} +unScriptSHA256 (ScriptSHA256 x) = x + +-- | Create a 'ScriptSHA256' from its 32 raw bytes. +parseScriptSHA256 :: B.ByteString -> Maybe ScriptSHA256 +{-# INLINE parseScriptSHA256 #-} +parseScriptSHA256 b = do + guard (B.length b == 32) + pure (ScriptSHA256 b) + +-- | Hash a 'S.Script' as required by 'Bitcoin.Address.P2WSH'. +scriptSHA256 :: S.Script -> ScriptSHA256 +{-# INLINE scriptSHA256 #-} +scriptSHA256 = ScriptSHA256 . sha256 . scriptBytes + + diff --git a/lib/Bitcoin/Address/Internal.hs b/lib/Bitcoin/Address/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Address/Internal.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_HADDOCK hide #-} +module Bitcoin.Address.Internal + ( op0to16 + , scriptBytes + , hush + ) where + +import qualified Data.Binary as Bin +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Bitcoin.Script as S + +-------------------------------------------------------------------------------- + +-- | Converts the numbers [0 … 16] to the corresponding ['S.OP_0' … 'S.OP_16']. +op0to16 :: Int -> Maybe S.ScriptOp +op0to16 i = case i of + 0 -> Just S.OP_0 + 1 -> Just S.OP_1 + 2 -> Just S.OP_2 + 3 -> Just S.OP_3 + 4 -> Just S.OP_4 + 5 -> Just S.OP_5 + 6 -> Just S.OP_6 + 7 -> Just S.OP_7 + 8 -> Just S.OP_8 + 9 -> Just S.OP_9 + 10 -> Just S.OP_10 + 11 -> Just S.OP_11 + 12 -> Just S.OP_12 + 13 -> Just S.OP_13 + 14 -> Just S.OP_14 + 15 -> Just S.OP_15 + 16 -> Just S.OP_16 + _ -> Nothing + +------------------------------------------------------------------------------- + +-- | Obtain the raw 'S.Script' bytes. +scriptBytes :: S.Script -> B.ByteString +scriptBytes = BL.toStrict . Bin.encode +{-# INLINE scriptBytes #-} + +-------------------------------------------------------------------------------- + +hush :: Either a b -> Maybe b +hush = either (\_ -> Nothing) Just +{-# INLINE hush #-} + diff --git a/lib/Bitcoin/Address/Script.hs b/lib/Bitcoin/Address/Script.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Address/Script.hs @@ -0,0 +1,108 @@ +-- | This module exports standard Bitcoin 'S.Script' constructions. +module Bitcoin.Address.Script + ( -- * Scripts + p2pkh + , p2sh + , segWit + , multiSig + ) where + +import Bitcoin.Keys (Pub, pubCompressed) +import Control.Monad +import qualified Data.Bitcoin.Script as S + +import Bitcoin.Address.Hash +import Bitcoin.Address.Internal (op0to16) +import qualified Bitcoin.Address.SegWit as SW + +-------------------------------------------------------------------------------- + +-- | Standard 'Bitcoin.Address.P2PKH' script. +-- +-- [pubh]: 'PubHash160'. +-- +-- Script: +-- +-- @ +-- 'S.OP_DUP' +-- 'S.OP_HASH160' +-- 'S.OP_PUSHDATA' pubh 'S.OPCODE' +-- 'S.OP_EQUALVERIFY' +-- 'S.OP_CHECKSIG' +-- @ +p2pkh :: PubHash160 -> S.Script +p2pkh pkh = S.Script + [ S.OP_DUP + , S.OP_HASH160 + , S.OP_PUSHDATA (unPubHash160 pkh) S.OPCODE + , S.OP_EQUALVERIFY + , S.OP_CHECKSIG + ] + +-- | Standard 'Bitcoin.Address.P2SH' script. +-- +-- [sh]: 'ScriptHash160'. +-- +-- Script: +-- +-- @ +-- 'S.OP_HASH160' +-- 'S.OP_PUSHDATA' sh 'S.OPCODE' +-- 'S.OP_EQUAL' +-- @ +p2sh :: ScriptHash160 -> S.Script +p2sh sh = S.Script + [ S.OP_HASH160 + , S.OP_PUSHDATA (unScriptHash160 sh) S.OPCODE + , S.OP_EQUAL + ] + +-- | Standard SegWit 'Bitcoin.Address.Program' script. +-- +-- [ver]: SegWit 'SW.versionOp' +-- +-- [prog]: SegWit 'SW.programData' +-- +-- Script: +-- +-- @ +-- ver +-- 'S.OP_PUSHDATA' prog 'S.OPCODE' +-- @ +segWit :: SW.Program -> S.Script +segWit swp = S.Script + [ SW.versionOp (SW.programVersion swp) + , S.OP_PUSHDATA (SW.programData swp ) S.OPCODE + ] + +-- | Standard “m-of-n” multi-signature script. +-- +-- [m]: Number of required signatures in range ['S.OP_1' … 'S.OP_16'] +-- +-- [n]: Number of 'Pub'lic keys given in range ['S.OP_1' … 'S.OP_16'] +-- +-- [pubs]: Compressed SEC representation the given 'Pub'lic keys, each one +-- (@pub@) encoded as @'S.OP_PUSHDATA' ('pubCompressed' pub) 'S.OPCODE'@. +-- +-- Script: +-- +-- @ +-- m +-- pubs +-- n +-- 'S.OP_CHECKMULTISIG' +-- @ +multiSig + :: [Pub] -- ^ Public keys. Total number in range [1 … 16] + -> Int -- ^ Required number of signatures in range [1, 16]. + -> Maybe S.Script -- ^ 'Nothing' if any of the inputs is invalid. +multiSig pks req = do + let len = length pks + guard (req >= 1 && req <= 16 && req <= len) + opLen <- op0to16 len + opReq <- op0to16 req + pure $ S.Script $ mconcat + [ [ opReq ] + , do pk <- pks + pure $ S.OP_PUSHDATA (pubCompressed pk) S.OPCODE + , [ opLen, S.OP_CHECKMULTISIG ] ] diff --git a/lib/Bitcoin/Address/SegWit.hs b/lib/Bitcoin/Address/SegWit.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Address/SegWit.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE StrictData #-} +module Bitcoin.Address.SegWit + ( -- * Version + Version + , version + , unVersion + , versionOp + , version0 + -- * Programs + , Program + , program + , programVersion + , programData + , renderProgram + -- ** Standard programs + , p2wpkh + , p2wsh + ) where + +import qualified Codec.Binary.Bech32 as Bech32 +import qualified Codec.Binary.Bech32.Internal as Bech32 +import Control.Monad +import qualified Data.Bitcoin.Script as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Text.Encoding as T +import Data.Word + +import Bitcoin.Address.Hash +import Bitcoin.Address.Internal (op0to16) +import Bitcoin.Address.Settings + +-------------------------------------------------------------------------------- + +-- | A SegWit program. Construct with 'program'. +data Program = Program Version B.ByteString + deriving (Eq, Ord) + +-- | Version and base-16 encoded program data. +instance Show Program where + showsPrec n (Program v d) = showParen (n > 10) $ + showString "Program " . + mappend (show v) . + mappend " " . + mappend (BL8.unpack (BB.toLazyByteString (BB.byteStringHex d))) + +-- | SegWit program version. +programVersion :: Program -> Version +{-# INLINE programVersion #-} +programVersion (Program v _) = v + +-- | Raw SegWit program data. +programData :: Program -> B.ByteString +{-# INLINE programData #-} +programData (Program _ x) = x + +-- | Construct a 'Program' from its raw bytes. +-- +-- __WARINING__ This function will prevent you frow constructing invalid SegWit +-- programs, but won't help you write __meaningful__ programs. Prefer to use +-- safe constructions such as 'p2wpkh' or 'p2wsh' instead. +program + :: Version + -> B.ByteString -- ^ Raw SegWit program bytes. + -> Maybe Program -- ^ Nothing if program length is invalid for version. +program ver prog = do + let len = B.length prog + guard $ case unVersion ver of + 0 -> len == 20 || len == 32 + _ -> len >= 2 && len <= 40 + pure (Program ver prog) + +-------------------------------------------------------------------------------- + +-- | Bech32-encode a 'Program'. +renderProgram :: PrefixSegWit -> Program -> B.ByteString +{-# INLINE renderProgram #-} +renderProgram pre (Program ver prog) = + let w5ver = toEnum $ fromIntegral $ unVersion ver + dver = Bech32.dataPartFromWords [w5ver] + dprog = Bech32.dataPartFromBytes prog + in T.encodeUtf8 $ Bech32.encodeLenient (prefixSegWitHRP pre) (dver <> dprog) + +-------------------------------------------------------------------------------- + +-- | The version for of a SegWit 'Program'. +newtype Version = Version Word8 + deriving (Eq, Ord, Show) + +-- | Construct a SegWit 'Version'. +-- +-- The given 'Word8' must be in the inclusive range [0 … 16]. +version :: Word8 -> Maybe Version +{-# INLINE version #-} +version w = do + guard (w <= 16) + Just (Version w) + +-- | The obtained 'Word8' is in the inclusive range [0 … 16]. +unVersion :: Version -> Word8 +{-# INLINE unVersion #-} +unVersion (Version w) = w + +-- | The 'S.ScriptOp' corresponding to the 'Version', in +-- range ['S.OP_0' … 'S.OP_16'] +versionOp :: Version -> S.ScriptOp +{-# INLINE versionOp #-} +versionOp (Version w) = case op0to16 (fromIntegral w) of + Just op -> op + Nothing -> undefined -- impossible + +-------------------------------------------------------------------------------- + +-- | SegWit version 0 +version0 :: Version +{-# INLINE version0 #-} +Just version0 = version 0 + +-- | Construct a standard SegWit version 0 P2WPKH program. +p2wpkh :: PubHash160 -> Program +{-# INLINE p2wpkh #-} +p2wpkh pkh = case program version0 (unPubHash160 pkh) of + Just prog -> prog + Nothing -> undefined -- impossible + +-- | Construct a standard SegWit version 0 P2WSH program. +p2wsh :: ScriptSHA256 -> Program +{-# INLINE p2wsh #-} +p2wsh sh = case program version0 (unScriptSHA256 sh) of + Just prog -> prog + Nothing -> undefined -- impossible + diff --git a/lib/Bitcoin/Address/Settings.hs b/lib/Bitcoin/Address/Settings.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Address/Settings.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE StrictData #-} +{-# OPTIONS_HADDOCK prune #-} + +-- | This module exports settings for different Bitcoin networks. +module Bitcoin.Address.Settings + ( -- * Settings + Settings(..) + -- ** PrefixP2PKH + , PrefixP2PKH(..) + -- ** PrefixP2SH + , PrefixP2SH(..) + -- ** PrefixSegWit + , PrefixSegWit + , prefixSegWit + , unPrefixSegWit + , prefixSegWitHRP + ) where + +import qualified Codec.Binary.Bech32 as Bech32 +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Text.Encoding as T +import Data.Word + +import Bitcoin.Address.Internal (hush) + +-------------------------------------------------------------------------------- + +-- | Bitcoin network settings +-- +-- For examples, see 'Bitcoin.Address.btc' or 'Bitcoin.Address.btcTestnet' in +-- "Bitcoin.Address". +data Settings = Settings + { settings_prefixP2PKH :: PrefixP2PKH + , settings_prefixP2SH :: PrefixP2SH + , settings_prefixSegWit :: PrefixSegWit + } deriving (Eq, Show) + +-------------------------------------------------------------------------------- + +-- | The byte prefix used in 'P2PKH' addresses. +newtype PrefixP2PKH = PrefixP2PKH { unPrefixP2PKH :: Word8 } + deriving newtype (Eq, Ord, Show) + +-------------------------------------------------------------------------------- + +-- | The byte prefix used in 'P2SH' addresses. +newtype PrefixP2SH = PrefixP2SH { unPrefixP2SH :: Word8 } + deriving newtype (Eq, Ord, Show) + +-------------------------------------------------------------------------------- + +-- | The Human Readable Part of a 'P2WPKH' or 'P2WSH' +-- address (e.g., the “bc” in “bc1…”) +newtype PrefixSegWit = PrefixSegWit Bech32.HumanReadablePart + deriving newtype (Eq) + +instance Ord PrefixSegWit where + compare a b = compare (unPrefixSegWit a) (unPrefixSegWit b) + +instance Show PrefixSegWit where + showsPrec n p = showParen (n > 10) $ + showString "PrefixSegWit " . + mappend (BL8.unpack (BB.toLazyByteString + (BB.byteStringHex (unPrefixSegWit p)))) + +prefixSegWitHRP :: PrefixSegWit -> Bech32.HumanReadablePart +prefixSegWitHRP (PrefixSegWit hrp) = hrp + +-- | Obtain the Bech32 Human Readable Part inside 'PrefixSegWit'. +unPrefixSegWit :: PrefixSegWit -> B.ByteString +unPrefixSegWit (PrefixSegWit hrp) = + T.encodeUtf8 (Bech32.humanReadablePartToText hrp) + +-- | Construct a 'PrefixSegWit' from the Bech32 Human Readable Part. +prefixSegWit :: B.ByteString -> Maybe PrefixSegWit +prefixSegWit b = do + t <- hush (T.decodeUtf8' b) + PrefixSegWit <$> hush (Bech32.humanReadablePartFromText t) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module Main (main) where + +import qualified Bitcoin.Keys as K +import qualified Data.Bitcoin.Script as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +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, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import qualified Bitcoin.Address as A +import qualified Bitcoin.Address.Hash as AH +import qualified Bitcoin.Address.Internal as AI +import qualified Bitcoin.Address.Script as ASC +import qualified Bitcoin.Address.SegWit as ASW +import qualified Bitcoin.Address.Settings as ASE + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] $ Tasty.localOption (HedgehogTestLimit (Just 100)) + $ tt + +tt :: TestTree +tt = testGroup "bitcoin-address" + [ tt_settings + , tt_script + , tt_hash + , tt_address + ] + +tt_settings :: TestTree +tt_settings = testGroup "Settings" + [ testCase "btc" $ do + let ASE.Settings preP2PKH preP2SH preSegWit = A.btc + preP2PKH @?= ASE.PrefixP2PKH { ASE.unPrefixP2PKH = 0x00 } + preP2SH @?= ASE.PrefixP2SH { ASE.unPrefixP2SH = 0x05 } + Just preSegWit @?= ASE.prefixSegWit "bc" + + , testCase "btcTestnet" $ do + let ASE.Settings preP2PKH preP2SH preSegWit = A.btcTestnet + preP2PKH @?= ASE.PrefixP2PKH { ASE.unPrefixP2PKH = 0x6f } + preP2SH @?= ASE.PrefixP2SH { ASE.unPrefixP2SH = 0xc4 } + Just preSegWit @?= ASE.prefixSegWit "tb" + ] + +tt_hash :: TestTree +tt_hash = testGroup "Hash" + [ testGroup "pubHash160" + [ testCase "pk1" $ do + toBase16 (AH.unPubHash160 pk1hash160) + @?= "5f04d673fdbd072b97558a8f830a5ddf655839d7" + + , testCase "pk2" $ do + toBase16 (AH.unPubHash160 pk2hash160) + @?= "980938e055943e47b73e5d16b2de7343a61a0a7b" + ] + , testGroup "pubUncompressedHash160" + [ testCase "pk1" $ do + toBase16 (AH.unPubHash160 (AH.pubUncompressedHash160 pk1)) + @?= "6baec369d3d75a0a27818c3560fe2c4db8f916d6" + + , testCase "pk2" $ do + toBase16 (AH.unPubHash160 (AH.pubUncompressedHash160 pk2)) + @?= "85b679742f15e5b24849747c8eab44c0eb508fbe" + ] + , testCase "scriptHash160" $ do + toBase16 (AH.unScriptHash160 (AH.scriptHash160 (ASC.p2pkh pk1hash160))) + @?= "929f8c79af58e615ffe465a76f44c02865b5b77b" + + , testCase "scriptSHA256" $ do + toBase16 (AH.unScriptSHA256 (AH.scriptSHA256 (ASC.p2pkh pk1hash160))) + @?= "a39b82cbb33b2ee51d0fd5e415ce924f3f4a120ae962c13ab2f9b6433326e0bf" + ] + +tt_script :: TestTree +tt_script = testGroup "Script" + [ tt_script_p2pkh + , tt_script_multiSig + , tt_script_p2sh + , tt_script_segWit + ] + +tt_script_p2pkh :: TestTree +tt_script_p2pkh = testGroup "P2PKH" + [ testCase "pk1" $ do + let s = ASC.p2pkh pk1hash160 + toBase16 (AI.scriptBytes s) @?= + "76a9145f04d673fdbd072b97558a8f830a5ddf655839d788ac" + + , testCase "pk2" $ do + let s = ASC.p2pkh pk2hash160 + toBase16 (AI.scriptBytes s) @?= + "76a914980938e055943e47b73e5d16b2de7343a61a0a7b88ac" + + , testProperty "prop" $ property $ do + pk <- forAll genPub + let pkh = AH.pubHash160 pk + s = ASC.p2pkh pkh + toBase16 (AI.scriptBytes s) === mconcat + [ "76a914", toBase16 (AH.unPubHash160 pkh), "88ac" ] + ] + + +tt_script_segWit :: TestTree +tt_script_segWit = testGroup "SegWit" + [ tt_script_segWit_p2wpkh + , tt_script_segWit_p2wsh + ] + +tt_script_segWit_p2wpkh :: TestTree +tt_script_segWit_p2wpkh = testGroup "P2WPKH" + [ testCase "pk1" $ do + let s = ASC.segWit (ASW.p2wpkh pk1hash160) + toBase16 (AI.scriptBytes s) @?= + "00145f04d673fdbd072b97558a8f830a5ddf655839d7" + + , testCase "pk2" $ do + let s = ASC.segWit (ASW.p2wpkh pk2hash160) + toBase16 (AI.scriptBytes s) @?= + "0014980938e055943e47b73e5d16b2de7343a61a0a7b" + + , testProperty "prop" $ property $ do + pk <- forAll genPub + let pkh = AH.pubHash160 pk + s = ASC.segWit (ASW.p2wpkh pkh) + toBase16 (AI.scriptBytes s) === mconcat + [ "0014", toBase16 (AH.unPubHash160 pkh) ] + ] + +tt_script_multiSig :: TestTree +tt_script_multiSig = testGroup "MultiSig" + [ testCase "1 of [pk1]" $ do + let Just s = ASC.multiSig [pk1] 1 + toBase16 (AI.scriptBytes s) @?= mconcat + ["5121", toBase16 (K.pubCompressed pk1), "51ae"] + + , testCase "1 of [pk2]" $ do + let Just s = ASC.multiSig [pk2] 1 + toBase16 (AI.scriptBytes s) @?= mconcat + ["5121", toBase16 (K.pubCompressed pk2), "51ae"] + + , testCase "1 of [pk1, pk2]" $ do + let Just s = ASC.multiSig [pk1, pk2] 1 + toBase16 (AI.scriptBytes s) @?= mconcat + [ "5121", toBase16 (K.pubCompressed pk1) + , "21", toBase16 (K.pubCompressed pk2) + , "52ae" ] + + , testCase "1 of [pk2, pk1]" $ do + let Just s = ASC.multiSig [pk2, pk1] 1 + toBase16 (AI.scriptBytes s) @?= mconcat + [ "5121", toBase16 (K.pubCompressed pk2) + , "21", toBase16 (K.pubCompressed pk1) + , "52ae" ] + + , testCase "2 of [pk1, pk2]" $ do + let Just s = ASC.multiSig [pk1, pk2] 2 + toBase16 (AI.scriptBytes s) @?= mconcat + [ "5221", toBase16 (K.pubCompressed pk1) + , "21", toBase16 (K.pubCompressed pk2) + , "52ae" ] + + , testCase "2 of [pk2, pk1]" $ do + let Just s = ASC.multiSig [pk2, pk1] 2 + toBase16 (AI.scriptBytes s) @?= mconcat + [ "5221", toBase16 (K.pubCompressed pk2) + , "21", toBase16 (K.pubCompressed pk1) + , "52ae"] + + , testProperty "0 of n (invalid)" $ property $ do + pks <- forAll $ Gen.list (Range.constant 0 20) genPub + Nothing === ASC.multiSig pks 0 + + , testProperty "m of [] (invalid)" $ property $ do + n <- forAll $ Gen.int (Range.constant (-20) 20) + Nothing === ASC.multiSig [] n + + , testProperty "m of n, m > n (invalid)" $ property $ do + pks <- forAll $ Gen.list (Range.constant 0 20) genPub + i <- forAll $ Gen.int (Range.constant 1 20) + Nothing === ASC.multiSig pks (length pks + i) + + , testProperty "m of n, n > 16 (invalid)" $ property $ do + pks <- forAll $ Gen.list (Range.constant 17 30) genPub + m <- forAll $ Gen.int (Range.constant 1 20) + Nothing === ASC.multiSig pks m + + , testProperty "m of n (correct)" $ property $ do + pks <- forAll $ Gen.list (Range.constant 1 16) genPub + m <- forAll $ Gen.int (Range.constant 1 (length pks)) + let Just mOp = AI.op0to16 m + Just nOp = AI.op0to16 (length pks) + pksOps = map (\pk -> S.OP_PUSHDATA (K.pubCompressed pk) S.OPCODE) pks + s = S.Script $ (mOp : pksOps) <> [nOp, S.OP_CHECKMULTISIG] + Just s === ASC.multiSig pks m + ] + +tt_script_p2sh :: TestTree +tt_script_p2sh = testGroup "P2SH" + [ tt_script_p2sh_p2wpkh + , tt_script_p2sh_multiSig + , tt_script_p2sh_p2wsh + ] + +tt_script_p2sh_p2wpkh :: TestTree +tt_script_p2sh_p2wpkh = testGroup "P2WPKH-in-P2SH" + [ testCase "pk1" $ do + let sw = ASC.segWit (ASW.p2wpkh pk1hash160) + swh = AH.scriptHash160 sw + s = ASC.p2sh swh + toBase16 (AI.scriptBytes s) @?= mconcat + [ "a914", toBase16 (AH.unScriptHash160 swh), "87" ] + toBase16 (AI.scriptBytes s) @?= + "a914ba9102a5c6407308a600e114cb3474bb179b1eca87" + + , testCase "pk2" $ do + let sw = ASC.segWit (ASW.p2wpkh pk2hash160) + swh = AH.scriptHash160 sw + s = ASC.p2sh swh + toBase16 (AI.scriptBytes s) @?= mconcat + [ "a914", toBase16 (AH.unScriptHash160 swh), "87" ] + toBase16 (AI.scriptBytes s) @?= + "a9140e8ee6d7778e0b708844a8c40b1f1c700de2489287" + + , testProperty "prop" $ property $ do + pk <- forAll genPub + let pkh = AH.pubHash160 pk + sw = ASC.segWit (ASW.p2wpkh pkh) + swh = AH.scriptHash160 sw + s = ASC.p2sh swh + toBase16 (AI.scriptBytes s) === mconcat + [ "a914", toBase16 (AH.unScriptHash160 swh), "87" ] + ] + +tt_script_p2sh_multiSig :: TestTree +tt_script_p2sh_multiSig = testGroup "MultiSig" + [ testCase "1 of [pk1, pk2]" $ do + let Just sMultiSig = ASC.multiSig [pk1, pk2] 1 + shMultiSig = AH.scriptHash160 sMultiSig + s = ASC.p2sh shMultiSig + toBase16 (AI.scriptBytes s) @?= mconcat + [ "a914", toBase16 (AH.unScriptHash160 shMultiSig), "87" ] + toBase16 (AI.scriptBytes s) @?= + "a914db9775b7424ddfd3a69d83c2a9a91bf7953197b187" + + , testProperty "prop" $ property $ do + pks <- forAll $ Gen.list (Range.constant 1 16) genPub + m <- forAll $ Gen.int (Range.constant 1 (length pks)) + let Just sMultiSig = ASC.multiSig pks m + shMultiSig = AH.scriptHash160 sMultiSig + s = ASC.p2sh shMultiSig + s === S.Script [ S.OP_HASH160 + , S.OP_PUSHDATA (AH.unScriptHash160 shMultiSig) S.OPCODE + , S.OP_EQUAL ] + toBase16 (AI.scriptBytes s) === mconcat + [ "a914", toBase16 (AH.unScriptHash160 shMultiSig), "87"] + ] + +tt_script_p2sh_p2wsh :: TestTree +tt_script_p2sh_p2wsh = testGroup "P2WSH-in-P2SH" + [ tt_script_p2sh_p2wsh_multiSig + ] + +tt_script_p2sh_p2wsh_multiSig :: TestTree +tt_script_p2sh_p2wsh_multiSig = testGroup "P2WSH-MultiSig-in-P2SH" + [ testCase "1 of [pk1, pk2]" $ do + let Just sMultiSig = ASC.multiSig [pk1, pk2] 1 + shMultiSig = AH.scriptSHA256 sMultiSig + sw = ASC.segWit (ASW.p2wsh shMultiSig) + swh = AH.scriptHash160 sw + s = ASC.p2sh swh + toBase16 (AI.scriptBytes s) @?= mconcat + [ "a914", toBase16 (AH.unScriptHash160 swh), "87" ] + toBase16 (AI.scriptBytes s) @?= + "a9140b5fd2183b91a75ae09e70122bf89e79e71ff1c387" + + , testProperty "prop" $ property $ do + pks <- forAll $ Gen.list (Range.constant 1 16) genPub + m <- forAll $ Gen.int (Range.constant 1 (length pks)) + let Just sMultiSig = ASC.multiSig pks m + shMultiSig = AH.scriptSHA256 sMultiSig + sw = ASC.segWit (ASW.p2wsh shMultiSig) + swh = AH.scriptHash160 sw + s = ASC.p2sh swh + s === S.Script [ S.OP_HASH160 + , S.OP_PUSHDATA (AH.unScriptHash160 swh) S.OPCODE + , S.OP_EQUAL ] + toBase16 (AI.scriptBytes s) === mconcat + [ "a914", toBase16 (AH.unScriptHash160 swh), "87" ] + let Just s' = A.addressScript <$> A.p2sh_p2wsh_multiSig A.btc pks m + s' === s + ] + +tt_script_segWit_p2wsh :: TestTree +tt_script_segWit_p2wsh = testGroup "P2WSH" + [ tt_script_segWit_p2wsh_multiSig + ] + +tt_script_segWit_p2wsh_multiSig :: TestTree +tt_script_segWit_p2wsh_multiSig = testGroup "MultiSig" + [ testCase "1 of [pk1, pk2]" $ do + let Just sMultiSig = ASC.multiSig [pk1, pk2] 1 + shMultiSig = AH.scriptSHA256 sMultiSig + s = ASC.segWit (ASW.p2wsh shMultiSig) + toBase16 (AI.scriptBytes s) @?= mconcat + [ "0020", toBase16 (AH.unScriptSHA256 shMultiSig) ] + toBase16 (AI.scriptBytes s) @?= + "00209d0d2b0482cfd102ae24a2720645b502fc9a56164ec54e87a51c8d4966cebdbe" + + , testProperty "prop" $ property $ do + pks <- forAll $ Gen.list (Range.constant 1 16) genPub + m <- forAll $ Gen.int (Range.constant 1 (length pks)) + let Just sMultiSig = ASC.multiSig pks m + shMultiSig = AH.scriptSHA256 sMultiSig + s = ASC.segWit (ASW.p2wsh shMultiSig) + s === S.Script [ S.OP_0 + , S.OP_PUSHDATA (AH.unScriptSHA256 shMultiSig) S.OPCODE ] + toBase16 (AI.scriptBytes s) === mconcat + [ "0020", toBase16 (AH.unScriptSHA256 shMultiSig) ] + ] + +tt_address :: TestTree +tt_address = testGroup "Address" + [ tt_address_btc + -- , tt_address_btcTestnet + ] + + +tt_address_btc :: TestTree +tt_address_btc = testGroup "BTC" + [ testGroup "p2pkh" + [ testCase "pk1" $ do + A.renderAddress (A.p2pkh A.btc pk1) @?= + "19fQzMWpVo5esC9e2HGJRWfB2bkYLGEqAb" + , testCase "pk2" $ do + A.renderAddress (A.p2pkh A.btc pk2) @?= + "1ErtkviCvV4H9a2cMCrHwb5LV1ir7aXJpF" + ] + , testGroup "p2wpkh" + [ testCase "pk1" $ do + A.renderAddress (A.p2wpkh A.btc pk1) @?= + "bc1qtuzdvulah5rjh964328cxzjamaj4swwhj47xg6" + , testCase "pk2" $ do + A.renderAddress (A.p2wpkh A.btc pk2) @?= + "bc1qnqyn3cz4jsly0de7t5tt9hnngwnp5znmk06th7" + ] + , testGroup "p2sh_p2wpkh" + [ testCase "pk1" $ do + A.renderAddress (A.p2sh_p2wpkh A.btc pk1) @?= + "3JhVKigMH4hyZzq1MJPjwZmKY5tV5z69nC" + , testCase "pk2" $ do + A.renderAddress (A.p2sh_p2wpkh A.btc pk2) @?= + "331zaDSamvQKX41nDATJPH1PKeMTQzfm22" + ] + , testGroup "p2sh_multiSig" + [ testCase "1 of [pk1]" $ do + fmap A.renderAddress (A.p2sh_multiSig A.btc [pk1] 1) @?= + Just "3H12mXUPXvZPd4ardUEEtZnyTCyWtq5ozH" + , testCase "1 of [pk2]" $ do + fmap A.renderAddress (A.p2sh_multiSig A.btc [pk2] 1) @?= + Just "3QUSu15rwtJXpLUUqGSCXG6i6j6Kv9RvQ5" + , testCase "1 of [pk1, pk2]" $ do + fmap A.renderAddress (A.p2sh_multiSig A.btc [pk1, pk2] 1) @?= + Just "3Mi7MAhA2MeiLM77yYCmBYNjQMkug2fET9" + , testCase "1 of [pk2, pk1]" $ do + fmap A.renderAddress (A.p2sh_multiSig A.btc [pk2, pk1] 1) @?= + Just "3PAA17FxCGdNFMjJMQWGQp1dyvxWcntDvs" + , testCase "2 of [pk1, pk2]" $ do + fmap A.renderAddress (A.p2sh_multiSig A.btc [pk1, pk2] 2) @?= + Just "36i3sEMYTsECQPq6yzrhFq1mWmQRqgn6g3" + , testCase "2 of [pk2, pk1]" $ do + fmap A.renderAddress (A.p2sh_multiSig A.btc [pk2, pk1] 2) @?= + Just "35CaUy8cA7xFSEFAS6mvCJbvugNS11nPBx" + ] + , testGroup "p2wsh_multiSig" + [ testCase "1 of [pk1]" $ do + fmap A.renderAddress (A.p2wsh_multiSig A.btc [pk1] 1) @?= + Just "bc1qw2v3lcjvu0mxsqhwt673nt0t2sehhge7hamqzzqg45jyah294lsqw2j5yj" + , testCase "1 of [pk2]" $ do + fmap A.renderAddress (A.p2wsh_multiSig A.btc [pk2] 1) @?= + Just "bc1q7x6l850snyxcxdlwjx3qty6rngkngxuhcjlr9a4dgk4975x6krnqzh99h6" + , testCase "1 of [pk1, pk2]" $ do + fmap A.renderAddress (A.p2wsh_multiSig A.btc [pk1, pk2] 1) @?= + Just "bc1qn5xjkpyzelgs9t3y5feqv3d4qt7f54skfmz5apa9rjx5jekwhklqajj224" + , testCase "1 of [pk2, pk1]" $ do + fmap A.renderAddress (A.p2wsh_multiSig A.btc [pk2, pk1] 1) @?= + Just "bc1qm29gsj6mr73kd7rg4ec848rcmujkgk05sthjcnhx2zeh09n5zcssw7j3pn" + , testCase "2 of [pk1, pk2]" $ do + fmap A.renderAddress (A.p2wsh_multiSig A.btc [pk2, pk1] 2) @?= + Just "bc1qwy7gugcea2f2kckzfhvfu34raw6fevu7dhncdec5gz03ll7lxauq3t0r6u" + , testCase "2 of [pk2, pk1]" $ do + fmap A.renderAddress (A.p2wsh_multiSig A.btc [pk1, pk2] 2) @?= + Just "bc1qxemuancumx68770699xahey9uqdc5qdc3572uxukdhg9wncztg3su4ecfy" + ] + , testGroup "p2sh_p2wsh_multiSig" + [ testCase "pk1" $ do + fmap A.renderAddress (A.p2sh_p2wsh_multiSig A.btc [pk1] 1) @?= + Just "323Jncw5hBt6KL1WMSao8RrE8CtrooBt9j" + , testCase "pk2" $ do + fmap A.renderAddress (A.p2sh_p2wsh_multiSig A.btc [pk2] 1) @?= + Just "39U3xFLp1KDcaixq6wyfHHsjiPvCCyVyDa" + , testCase "1 of [pk1, pk2]" $ do + fmap A.renderAddress (A.p2sh_p2wsh_multiSig A.btc [pk1, pk2] 1) @?= + Just "32jA9PfdTQ74svaSQjTZPLeV98WiHEHJF3" + , testCase "1 of [pk2, pk1]" $ do + fmap A.renderAddress (A.p2sh_p2wsh_multiSig A.btc [pk2, pk1] 1) @?= + Just "3GSfokgqW2G77VzTrojnPa1sNjSnYuwDuX" + , testCase "2 of [pk1, pk2]" $ do + fmap A.renderAddress (A.p2sh_p2wsh_multiSig A.btc [pk1, pk2] 2) @?= + Just "3EeuEEn1uwdm2GwctKqSjBV4xPp1JiECgm" + , testCase "2 of [pk2, pk1]" $ do + fmap A.renderAddress (A.p2sh_p2wsh_multiSig A.btc [pk2, pk1] 2) @?= + Just "35LhobEZN2QLpYfMfH35tTyxrxYpANBBkA" + ] + ] + +-------------------------------------------------------------------------------- + +genPub :: MonadGen m => m K.Pub +genPub = go 10000 where + go 0 = error "genPub: too many attempts" + go n = do + h <- Gen.element [2, 3 :: Word8] + b <- Gen.bytes (Range.singleton 32) + case K.parsePub (B.cons h b) of + Just k -> pure k + Nothing -> go (n - 1) + +-------------------------------------------------------------------------------- +-- BIP39 mnemonic: abandon abandon arm +-- +-- BIP39 seed: 2f7b8b6eeeb7201d88ed45dcd4706ccd76e5feb61f1961990869581781f8944ae2bebff36156c6965054add29f2cf9ee8b7b488179bfba24773ce2b06ec0ce04 +-- +-- BIP32 Derivation path: m/44'/0'/0'/0/0 +-- +-- Private key WIF: L1CnCq2yTvfzngQTF4Fnh5daYUwAuysrqU5dNwZFcv33Cwu4Gf2F + +pk1 :: K.Pub +Just pk1 = K.parsePub $ fromBase16 + "024ed59d3f6548c41172ec26b9144f547185cb2a9f28fccb6e3ae53dc4f1827154" + +pk1hash160 :: AH.PubHash160 +pk1hash160 = AH.pubHash160 pk1 + +-------------------------------------------------------------------------------- +-- BIP39 mnemonic: abandon abandon arm +-- +-- BIP39 seed: 2f7b8b6eeeb7201d88ed45dcd4706ccd76e5feb61f1961990869581781f8944ae2bebff36156c6965054add29f2cf9ee8b7b488179bfba24773ce2b06ec0ce04 +-- +-- BIP32 Derivation path: m/84'/0'/0'/0/0 +-- +-- Private key WIF: L3XRaAfqnZLCcUpcCi4g1GqMLTKvr9nbvCYBmrs1TAjx4acpZ2eY + +pk2 :: K.Pub +Just pk2 = K.parsePub $ fromBase16 + "0315bd146d8b45383ad431a8204717dc9f46a7a46c1f44eeaab02d49f4511ccff0" + +pk2hash160 :: AH.PubHash160 +pk2hash160 = AH.pubHash160 pk2 + +-------------------------------------------------------------------------------- + +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) +