ppad-script (empty) → 0.1.0
raw patch · 7 files changed
+893/−0 lines, 7 filesdep +basedep +bytestringdep +criterion
Dependencies added: base, bytestring, criterion, deepseq, ppad-base16, ppad-script, primitive, tasty, tasty-hunit, tasty-quickcheck, weigh
Files
- CHANGELOG +7/−0
- LICENSE +20/−0
- bench/Main.hs +83/−0
- bench/Weight.hs +41/−0
- lib/Bitcoin/Prim/Script.hs +442/−0
- ppad-script.cabal +87/−0
- test/Main.hs +213/−0
+ CHANGELOG view
@@ -0,0 +1,7 @@+# Changelog++- 0.1.0 (2025-01-19)+ * Initial release supporting basic representations of Script, as well+ as utility functions for converting between them.++
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ bench/Main.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++module Main where++import Bitcoin.Prim.Script (Term(..), Opcode(..))+import qualified Bitcoin.Prim.Script as S+import Control.DeepSeq+import Criterion.Main+import qualified Data.ByteString as BS+import qualified Data.Primitive.ByteArray as BA+import GHC.Generics++deriving stock instance Generic S.Script+instance NFData S.Script++deriving stock instance Generic S.Term+instance NFData S.Term++deriving stock instance Generic S.Opcode+instance NFData S.Opcode++ba_to_bs :: Benchmark+ba_to_bs = env setup $ \ba ->+ bench "ba_to_bs" $ nf S.ba_to_bs ba+ where+ setup = do+ let s = 1024 :: Int+ ba <- BA.newPinnedByteArray s+ let go !j+ | j == s = pure ()+ | otherwise = do+ BA.writeByteArray ba j (j `rem` 256)+ go (j + 1)+ go 0+ BA.unsafeFreezeByteArray ba++bs_to_ba :: Benchmark+bs_to_ba = bench "bs_to_ba" $ nf S.bs_to_ba (BS.replicate 1024 0x00)++to_script :: Benchmark+to_script = bench "to_script" $ nf S.to_script terms where+ terms = [+ OPCODE OP_DUP,OPCODE OP_HASH160,OPCODE OP_PUSHBYTES_20,BYTE 0x89,BYTE 0xab+ , BYTE 0xcd,BYTE 0xef,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab+ , BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba+ , BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,OPCODE OP_EQUALVERIFY+ , OPCODE OP_CHECKSIG+ ]++from_script :: Benchmark+from_script = bench "from_script" $ nf S.from_script script where+ b16 = "76a91489abcdefabbaabbaabbaabbaabbaabbaabbaabba88ac"+ script = case S.from_base16 b16 of+ Nothing -> error "invalid script"+ Just !s -> s++to_base16 :: Benchmark+to_base16 = bench "to_base16" $ nf S.to_base16 script where+ b16 = "76a91489abcdefabbaabbaabbaabbaabbaabbaabbaabba88ac"+ script = case S.from_base16 b16 of+ Nothing -> error "invalid script"+ Just !s -> s++from_base16 :: Benchmark+from_base16 = bench "from_base16" $ nf S.from_base16 b16 where+ b16 = "76a91489abcdefabbaabbaabbaabbaabbaabbaabbaabba88ac"++main :: IO ()+main = defaultMain [+ ba_to_bs+ , bs_to_ba+ , to_script+ , from_script+ , to_base16+ , from_base16+ ]+
+ bench/Weight.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE StandaloneDeriving #-}++module Main where++import Bitcoin.Prim.Script+import Control.DeepSeq+import qualified Data.ByteString as BS+import GHC.Generics+import qualified Weigh as W++deriving stock instance Generic Script+instance NFData Script++deriving stock instance Generic Term+instance NFData Term++deriving stock instance Generic Opcode+instance NFData Opcode++main :: IO ()+main = W.mainWith $ do+ W.func "bs_to_ba" bs_to_ba (BS.replicate 1024 0x00)+ W.func "ba_to_bs" ba_to_bs ba+ W.func "to_script" to_script terms+ W.func "from_script" from_script script+ where+ ba = bs_to_ba (BS.replicate 1024 0x00)+ script = to_script terms+ terms = [+ OPCODE OP_DUP,OPCODE OP_HASH160,OPCODE OP_PUSHBYTES_20,BYTE 0x89,BYTE 0xab+ , BYTE 0xcd,BYTE 0xef,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab+ , BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba+ , BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,OPCODE OP_EQUALVERIFY+ , OPCODE OP_CHECKSIG+ ]+
+ lib/Bitcoin/Prim/Script.hs view
@@ -0,0 +1,442 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: Bitcoin.Prim.Script+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Representations for [Script](https://en.bitcoin.it/wiki/Script),+-- including abstract syntax, 'ByteArray', and base16-encoded+-- 'ByteString' versions, as well as fast conversion utilities for+-- working with them.++module Bitcoin.Prim.Script (+ -- * Script and Script Terms+ Script(..)+ , Term(..)+ , Opcode(..)++ -- * Conversion Utilities+ , to_base16+ , from_base16+ , to_script+ , from_script++ -- for testing etc.+ , ba_to_bs+ , bs_to_ba+ ) where++import Control.Monad (guard)+import qualified Data.Bits as B+import Data.Bits ((.&.), (.|.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Unsafe as BU+import qualified Data.Char as C+import qualified Data.Primitive.ByteArray as BA+import Data.Word (Word8, Word16, Word32)+import GHC.ForeignPtr+import System.IO.Unsafe++-- utilities ------------------------------------------------------------------++fi :: (Num a, Integral b) => b -> a+fi = fromIntegral+{-# INLINE fi #-}++-- convert a pinned ByteArray to a ByteString+ba_to_bs :: BA.ByteArray -> BS.ByteString+ba_to_bs ba = unsafeDupablePerformIO $ do+ guard (BA.isByteArrayPinned ba)+ let l = BA.sizeofByteArray ba+ buf <- mallocPlainForeignPtrBytes l+ withForeignPtr buf $ \p ->+ BA.copyByteArrayToAddr p ba 0 l+ pure (BI.BS buf l)+{-# NOINLINE ba_to_bs #-}++-- convert a ByteString to a pinned ByteArray+bs_to_ba :: BS.ByteString -> BA.ByteArray+bs_to_ba (BI.PS bp _ l) = unsafeDupablePerformIO $ do+ buf <- BA.newPinnedByteArray l+ withForeignPtr bp $ \p ->+ BA.copyPtrToMutableByteArray buf 0 p l+ BA.unsafeFreezeByteArray buf+{-# NOINLINE bs_to_ba #-}++-- split a word8 into a pair of its high and low bits+-- only used for show instances+hilo :: Word8 -> (Word8, Word8)+hilo b =+ let hex_charset = "0123456789abcdef"+ hi = BU.unsafeIndex hex_charset (fi b `B.shiftR` 4)+ lo = BU.unsafeIndex hex_charset (fi b .&. 0b0000_1111)+ in (hi, lo)++-- script and term representation ---------------------------------------------++-- | A Script program, represented as a 'ByteArray'.+newtype Script = Script BA.ByteArray+ deriving (Eq, Show)++-- | Terms of the Script language (either opcodes or bytes).+data Term =+ OPCODE {-# UNPACK #-} !Opcode+ | BYTE {-# UNPACK #-} !Word8+ deriving Eq++instance Show Term where+ show (OPCODE o) = show o+ show (BYTE w) =+ let (hi, lo) = hilo w+ in "0x" <> (C.chr (fi hi) : C.chr (fi lo) : [])++-- script conversions ---------------------------------------------------------++-- | Convert a 'Script' to a base16-encoded ByteString.+to_base16 :: Script -> BS.ByteString+to_base16 (Script ba) = B16.encode (ba_to_bs ba)+{-# INLINE to_base16 #-}++-- | Convert a base16-encoded ByteString to a Script.+from_base16 :: BS.ByteString -> Maybe Script+from_base16 b16 = do+ bs <- B16.decode b16+ pure (Script (bs_to_ba bs))+{-# INLINE from_base16 #-}++-- | Pack a list of Script terms into a 'Script'.+to_script :: [Term] -> Script+to_script terms =+ let !bs = BS.pack (fmap term_to_byte terms)+ in Script (bs_to_ba bs)+ where+ term_to_byte :: Term -> Word8+ term_to_byte = \case+ OPCODE !op -> fi (fromEnum op)+ BYTE !w8 -> w8+ {-# INLINE term_to_byte #-}+{-# NOINLINE to_script #-} -- inlining causes GHC to panic during compilation++-- | Unpack a 'Script' into a list of Script terms.+from_script :: Script -> [Term]+from_script (Script bs) = go 0 where+ !l = BA.sizeofByteArray bs++ read_pay !cur !end+ | cur == end = go cur+ | otherwise = BYTE (BA.indexByteArray bs cur) : read_pay (cur + 1) end++ go j+ | j == l = mempty+ | otherwise =+ let !op = toEnum (fi (BA.indexByteArray bs j :: Word8)) :: Opcode+ in case pushbytes op of+ Just !i -> OPCODE op : read_pay (j + 1) (j + 1 + i)+ Nothing -> OPCODE op : case op of+ OP_PUSHDATA1 ->+ let !len_idx = j + 1+ !pay_len = BA.indexByteArray bs len_idx :: Word8+ in BYTE pay_len+ : read_pay (len_idx + 1) (len_idx + 1 + fi pay_len)++ OP_PUSHDATA2 ->+ let !len_idx = j + 1+ !w8_0 = BA.indexByteArray bs len_idx :: Word8+ !w8_1 = BA.indexByteArray bs (len_idx + 1) :: Word8+ !pay_len = fi w8_0 .|. fi w8_1 `B.shiftL` 8 :: Word16+ in BYTE w8_0 : BYTE w8_1+ : read_pay (len_idx + 2) (len_idx + 2 + fi pay_len)++ OP_PUSHDATA4 ->+ let !len_idx = j + 1+ !w8_0 = BA.indexByteArray bs len_idx :: Word8+ !w8_1 = BA.indexByteArray bs (len_idx + 1) :: Word8+ !w8_2 = BA.indexByteArray bs (len_idx + 2) :: Word8+ !w8_3 = BA.indexByteArray bs (len_idx + 3) :: Word8+ !pay_len = fi w8_0+ .|. fi w8_1 `B.shiftL` 8+ .|. fi w8_2 `B.shiftL` 16+ .|. fi w8_3 `B.shiftL` 24 :: Word32+ in BYTE w8_0 : BYTE w8_1 : BYTE w8_2 : BYTE w8_3+ : read_pay (len_idx + 4) (len_idx + 4 + fi pay_len)++ _ -> go (succ j)++-- opcodes and utilities ------------------------------------------------------++-- | Primitive opcodes.+data Opcode =+ OP_PUSHBYTES_0+ | OP_PUSHBYTES_1+ | OP_PUSHBYTES_2+ | OP_PUSHBYTES_3+ | OP_PUSHBYTES_4+ | OP_PUSHBYTES_5+ | OP_PUSHBYTES_6+ | OP_PUSHBYTES_7+ | OP_PUSHBYTES_8+ | OP_PUSHBYTES_9+ | OP_PUSHBYTES_10+ | OP_PUSHBYTES_11+ | OP_PUSHBYTES_12+ | OP_PUSHBYTES_13+ | OP_PUSHBYTES_14+ | OP_PUSHBYTES_15+ | OP_PUSHBYTES_16+ | OP_PUSHBYTES_17+ | OP_PUSHBYTES_18+ | OP_PUSHBYTES_19+ | OP_PUSHBYTES_20+ | OP_PUSHBYTES_21+ | OP_PUSHBYTES_22+ | OP_PUSHBYTES_23+ | OP_PUSHBYTES_24+ | OP_PUSHBYTES_25+ | OP_PUSHBYTES_26+ | OP_PUSHBYTES_27+ | OP_PUSHBYTES_28+ | OP_PUSHBYTES_29+ | OP_PUSHBYTES_30+ | OP_PUSHBYTES_31+ | OP_PUSHBYTES_32+ | OP_PUSHBYTES_33+ | OP_PUSHBYTES_34+ | OP_PUSHBYTES_35+ | OP_PUSHBYTES_36+ | OP_PUSHBYTES_37+ | OP_PUSHBYTES_38+ | OP_PUSHBYTES_39+ | OP_PUSHBYTES_40+ | OP_PUSHBYTES_41+ | OP_PUSHBYTES_42+ | OP_PUSHBYTES_43+ | OP_PUSHBYTES_44+ | OP_PUSHBYTES_45+ | OP_PUSHBYTES_46+ | OP_PUSHBYTES_47+ | OP_PUSHBYTES_48+ | OP_PUSHBYTES_49+ | OP_PUSHBYTES_50+ | OP_PUSHBYTES_51+ | OP_PUSHBYTES_52+ | OP_PUSHBYTES_53+ | OP_PUSHBYTES_54+ | OP_PUSHBYTES_55+ | OP_PUSHBYTES_56+ | OP_PUSHBYTES_57+ | OP_PUSHBYTES_58+ | OP_PUSHBYTES_59+ | OP_PUSHBYTES_60+ | OP_PUSHBYTES_61+ | OP_PUSHBYTES_62+ | OP_PUSHBYTES_63+ | OP_PUSHBYTES_64+ | OP_PUSHBYTES_65+ | OP_PUSHBYTES_66+ | OP_PUSHBYTES_67+ | OP_PUSHBYTES_68+ | OP_PUSHBYTES_69+ | OP_PUSHBYTES_70+ | OP_PUSHBYTES_71+ | OP_PUSHBYTES_72+ | OP_PUSHBYTES_73+ | OP_PUSHBYTES_74+ | OP_PUSHBYTES_75+ | OP_PUSHDATA1+ | OP_PUSHDATA2+ | OP_PUSHDATA4+ | OP_PUSHNUM_NEG1+ | OP_RESERVED+ | OP_PUSHNUM_1+ | OP_PUSHNUM_2+ | OP_PUSHNUM_3+ | OP_PUSHNUM_4+ | OP_PUSHNUM_5+ | OP_PUSHNUM_6+ | OP_PUSHNUM_7+ | OP_PUSHNUM_8+ | OP_PUSHNUM_9+ | OP_PUSHNUM_10+ | OP_PUSHNUM_11+ | OP_PUSHNUM_12+ | OP_PUSHNUM_13+ | OP_PUSHNUM_14+ | OP_PUSHNUM_15+ | OP_PUSHNUM_16+ | OP_NOP+ | OP_VER+ | OP_IF+ | OP_NOTIF+ | OP_VERIF+ | OP_VERNOTIF+ | OP_ELSE+ | OP_ENDIF+ | OP_VERIFY+ | OP_RETURN+ | OP_TOALTSTACK+ | OP_FROMALTSTACK+ | OP_2DROP+ | OP_2DUP+ | OP_3DUP+ | OP_2OVER+ | OP_2ROT+ | OP_2SWAP+ | OP_IFDUP+ | OP_DEPTH+ | OP_DROP+ | OP_DUP+ | OP_NIP+ | OP_OVER+ | OP_PICK+ | OP_ROLL+ | OP_ROT+ | OP_SWAP+ | OP_TUCK+ | OP_CAT+ | OP_SUBSTR+ | OP_LEFT+ | OP_RIGHT+ | OP_SIZE+ | OP_INVERT+ | OP_AND+ | OP_OR+ | OP_XOR+ | OP_EQUAL+ | OP_EQUALVERIFY+ | OP_RESERVED1+ | OP_RESERVED2+ | OP_1ADD+ | OP_1SUB+ | OP_2MUL+ | OP_2DIV+ | OP_NEGATE+ | OP_ABS+ | OP_NOT+ | OP_0NOTEQUAL+ | OP_ADD+ | OP_SUB+ | OP_MUL+ | OP_DIV+ | OP_MOD+ | OP_LSHIFT+ | OP_RSHIFT+ | OP_BOOLAND+ | OP_BOOLOR+ | OP_NUMEQUAL+ | OP_NUMEQUALVERIFY+ | OP_NUMNOTEQUAL+ | OP_LESSTHAN+ | OP_GREATERTHAN+ | OP_LESSTHANOREQUAL+ | OP_GREATERTHANOREQUAL+ | OP_MIN+ | OP_MAX+ | OP_WITHIN+ | OP_RIPEMD160+ | OP_SHA1+ | OP_SHA256+ | OP_HASH160+ | OP_HASH256+ | OP_CODESEPARATOR+ | OP_CHECKSIG+ | OP_CHECKSIGVERIFY+ | OP_CHECKMULTISIG+ | OP_CHECKMULTISIGVERIFY+ | OP_NOP1+ | OP_CLTV+ | OP_CSV+ | OP_NOP4+ | OP_NOP5+ | OP_NOP6+ | OP_NOP7+ | OP_NOP8+ | OP_NOP9+ | OP_NOP10+ | OP_CHECKSIGADD+ | OP_RETURN_187+ | OP_RETURN_188+ | OP_RETURN_189+ | OP_RETURN_190+ | OP_RETURN_191+ | OP_RETURN_192+ | OP_RETURN_193+ | OP_RETURN_194+ | OP_RETURN_195+ | OP_RETURN_196+ | OP_RETURN_197+ | OP_RETURN_198+ | OP_RETURN_199+ | OP_RETURN_200+ | OP_RETURN_201+ | OP_RETURN_202+ | OP_RETURN_203+ | OP_RETURN_204+ | OP_RETURN_205+ | OP_RETURN_206+ | OP_RETURN_207+ | OP_RETURN_208+ | OP_RETURN_209+ | OP_RETURN_210+ | OP_RETURN_211+ | OP_RETURN_212+ | OP_RETURN_213+ | OP_RETURN_214+ | OP_RETURN_215+ | OP_RETURN_216+ | OP_RETURN_217+ | OP_RETURN_218+ | OP_RETURN_219+ | OP_RETURN_220+ | OP_RETURN_221+ | OP_RETURN_222+ | OP_RETURN_223+ | OP_RETURN_224+ | OP_RETURN_225+ | OP_RETURN_226+ | OP_RETURN_227+ | OP_RETURN_228+ | OP_RETURN_229+ | OP_RETURN_230+ | OP_RETURN_231+ | OP_RETURN_232+ | OP_RETURN_233+ | OP_RETURN_234+ | OP_RETURN_235+ | OP_RETURN_236+ | OP_RETURN_237+ | OP_RETURN_238+ | OP_RETURN_239+ | OP_RETURN_240+ | OP_RETURN_241+ | OP_RETURN_242+ | OP_RETURN_243+ | OP_RETURN_244+ | OP_RETURN_245+ | OP_RETURN_246+ | OP_RETURN_247+ | OP_RETURN_248+ | OP_RETURN_249+ | OP_RETURN_250+ | OP_RETURN_251+ | OP_RETURN_252+ | OP_RETURN_253+ | OP_RETURN_254+ | OP_INVALIDOPCODE+ deriving (Eq, Show, Enum)++-- convert a pushbytes opcode to its corresponding int+pushbytes :: Opcode -> Maybe Int+pushbytes (fromEnum -> op)+ | op < 76 = Just $! fi op+ | otherwise = Nothing+
+ ppad-script.cabal view
@@ -0,0 +1,87 @@+cabal-version: 3.0+name: ppad-script+version: 0.1.0+synopsis: Primitive Script support.+license: MIT+license-file: LICENSE+author: Jared Tobin+maintainer: jared@ppad.tech+category: Cryptography+build-type: Simple+tested-with: GHC == { 9.8.1 }+extra-doc-files: CHANGELOG+description:+ Representations for [Script](https://en.bitcoin.it/wiki/Script),+ including abstract syntax, 'ByteArray', and base16-encoded+ 'ByteString' versions, as well as fast conversion utilities for+ working with them.++source-repository head+ type: git+ location: git.ppad.tech/script.git++library+ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options:+ -Wall+ exposed-modules:+ Bitcoin.Prim.Script+ build-depends:+ base >= 4.9 && < 5+ , bytestring >= 0.9 && < 0.13+ , primitive >= 0.8 && < 0.10+ , ppad-base16 >= 0.1 && < 0.2++test-suite script-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs++ ghc-options:+ -rtsopts -Wall++ build-depends:+ , base+ , bytestring+ , ppad-base16+ , ppad-script+ , primitive+ , tasty+ , tasty-hunit+ , tasty-quickcheck++benchmark script-bench+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Main.hs++ ghc-options:+ -rtsopts -O2 -Wall++ build-depends:+ base+ , bytestring+ , criterion+ , deepseq+ , ppad-script+ , primitive++benchmark script-weigh+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Weight.hs++ ghc-options:+ -rtsopts -O2 -Wall++ build-depends:+ base+ , bytestring+ , deepseq+ , ppad-script+ , weigh+
+ test/Main.hs view
@@ -0,0 +1,213 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Bitcoin.Prim.Script+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.Primitive.ByteArray as BA+import Test.Tasty+import qualified Test.Tasty.HUnit as H+import qualified Test.Tasty.QuickCheck as Q++-- types ----------------------------------------------------------------------++newtype BS = BS BS.ByteString+ deriving (Eq, Show)++bytes :: Int -> Q.Gen BS.ByteString+bytes k = do+ l <- Q.chooseInt (0, k)+ v <- Q.vectorOf l Q.arbitrary+ pure (BS.pack v)++instance Q.Arbitrary BS where+ arbitrary = do+ b <- bytes 20_000+ pure (BS b)++newtype HexBS = HexBS BS.ByteString+ deriving (Eq, Show)++instance Q.Arbitrary HexBS where+ arbitrary = do+ b <- bytes 20_000+ pure (HexBS (B16.encode b))++instance Q.Arbitrary BA.ByteArray where+ arbitrary = do+ b <- bytes 20_000+ pure (bs_to_ba b)++-- generated scripts will tend to be pathological due to pushdata+newtype RawScript = RawScript Script+ deriving (Eq, Show)++instance Q.Arbitrary RawScript where+ arbitrary = fmap (RawScript . Script) Q.arbitrary++-- XX better generators would be nice.+-- pushdata generation needs to be handled carefully.++newtype NonPathologicalScript = NonPathologicalScript Script+ deriving (Eq, Show)++instance Q.Arbitrary NonPathologicalScript where+ arbitrary = do+ l <- Q.chooseInt (0, 1_024)+ -- pushdata must be added with care; easy to blow up quickcheck+ bs <- fmap BS.pack (Q.vectorOf l (Q.chooseEnum (80, 255)))+ pure (NonPathologicalScript (Script (bs_to_ba bs)))++-- properties -----------------------------------------------------------------++ba_to_bs_inverts_bs_to_ba :: BS -> Bool+ba_to_bs_inverts_bs_to_ba (BS bs) = ba_to_bs (bs_to_ba bs) == bs++bs_to_ba_inverts_ba_to_bs :: BA.ByteArray -> Bool+bs_to_ba_inverts_ba_to_bs ba = bs_to_ba (ba_to_bs ba) == ba++from_base16_inverts_to_base16 :: RawScript -> Bool+from_base16_inverts_to_base16 (RawScript s) =+ let mscript = from_base16 (to_base16 s)+ in case mscript of+ Nothing -> False+ Just script -> script == s++to_base16_inverts_from_base16 :: HexBS -> Bool+to_base16_inverts_from_base16 (HexBS bs) =+ let mscript = from_base16 bs+ in case mscript of+ Nothing -> False+ Just script -> to_base16 script == bs++-- we can only use 'from_script' on non-pathological scripts+--+-- note the converse (from_script . to_script ~ id) is not true+to_script_inverts_from_script :: NonPathologicalScript -> Bool+to_script_inverts_from_script (NonPathologicalScript s) =+ let !terms = from_script s+ !script = to_script terms+ in script == s++-- assertions -----------------------------------------------------------------++decodes_to :: BS.ByteString -> [Term] -> H.Assertion+decodes_to bs ts = do+ let mscript = from_base16 bs+ case mscript of+ Nothing -> H.assertFailure "invalid bytestring"+ Just script -> do+ let terms = from_script script+ H.assertEqual mempty terms ts++-- p2pkh+p2pkh :: BS.ByteString+p2pkh = "76a91489abcdefabbaabbaabbaabbaabbaabbaabbaabba88ac"++p2pkh_terms :: [Term]+p2pkh_terms = [+ OPCODE OP_DUP,OPCODE OP_HASH160,OPCODE OP_PUSHBYTES_20,BYTE 0x89,BYTE 0xab+ , BYTE 0xcd,BYTE 0xef,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab+ , BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba+ , BYTE 0xab,BYTE 0xba,BYTE 0xab,BYTE 0xba,OPCODE OP_EQUALVERIFY+ , OPCODE OP_CHECKSIG+ ]++p2pkh_script_decodes_as_expected :: H.Assertion+p2pkh_script_decodes_as_expected = p2pkh `decodes_to` p2pkh_terms++-- p2sh+p2sh :: BS.ByteString+p2sh = "5221038282263212c609d9ea2a6e3e172de238d8c39cabe56f3f9e451d2c4c7739ba8721031b84c5567b126440995d3ed5aaba0565d71e1834604819ff9c17f5e9d5dd078f2102b4632d08485ff1df2db55b9dafd23347d1c47a457072a1e87be26896549a873753ae"++p2sh_terms :: [Term]+p2sh_terms = [OPCODE OP_PUSHNUM_2,OPCODE OP_PUSHBYTES_33,BYTE 0x03,BYTE 0x82,BYTE 0x82,BYTE 0x26,BYTE 0x32,BYTE 0x12,BYTE 0xc6,BYTE 0x09,BYTE 0xd9,BYTE 0xea,BYTE 0x2a,BYTE 0x6e,BYTE 0x3e,BYTE 0x17,BYTE 0x2d,BYTE 0xe2,BYTE 0x38,BYTE 0xd8,BYTE 0xc3,BYTE 0x9c,BYTE 0xab,BYTE 0xe5,BYTE 0x6f,BYTE 0x3f,BYTE 0x9e,BYTE 0x45,BYTE 0x1d,BYTE 0x2c,BYTE 0x4c,BYTE 0x77,BYTE 0x39,BYTE 0xba,BYTE 0x87,OPCODE OP_PUSHBYTES_33,BYTE 0x03,BYTE 0x1b,BYTE 0x84,BYTE 0xc5,BYTE 0x56,BYTE 0x7b,BYTE 0x12,BYTE 0x64,BYTE 0x40,BYTE 0x99,BYTE 0x5d,BYTE 0x3e,BYTE 0xd5,BYTE 0xaa,BYTE 0xba,BYTE 0x05,BYTE 0x65,BYTE 0xd7,BYTE 0x1e,BYTE 0x18,BYTE 0x34,BYTE 0x60,BYTE 0x48,BYTE 0x19,BYTE 0xff,BYTE 0x9c,BYTE 0x17,BYTE 0xf5,BYTE 0xe9,BYTE 0xd5,BYTE 0xdd,BYTE 0x07,BYTE 0x8f,OPCODE OP_PUSHBYTES_33,BYTE 0x02,BYTE 0xb4,BYTE 0x63,BYTE 0x2d,BYTE 0x08,BYTE 0x48,BYTE 0x5f,BYTE 0xf1,BYTE 0xdf,BYTE 0x2d,BYTE 0xb5,BYTE 0x5b,BYTE 0x9d,BYTE 0xaf,BYTE 0xd2,BYTE 0x33,BYTE 0x47,BYTE 0xd1,BYTE 0xc4,BYTE 0x7a,BYTE 0x45,BYTE 0x70,BYTE 0x72,BYTE 0xa1,BYTE 0xe8,BYTE 0x7b,BYTE 0xe2,BYTE 0x68,BYTE 0x96,BYTE 0x54,BYTE 0x9a,BYTE 0x87,BYTE 0x37,OPCODE OP_PUSHNUM_3,OPCODE OP_CHECKMULTISIG]++p2sh_script_decodes_as_expected :: H.Assertion+p2sh_script_decodes_as_expected = p2sh `decodes_to` p2sh_terms++-- p2wpkh+p2wpkh :: BS.ByteString+p2wpkh = "0014b472a266d0bd89c13706a4132ccfb16f7c3b9fcb"++p2wpkh_terms :: [Term]+p2wpkh_terms = [OPCODE OP_PUSHBYTES_0,OPCODE OP_PUSHBYTES_20,BYTE 0xb4,BYTE 0x72,BYTE 0xa2,BYTE 0x66,BYTE 0xd0,BYTE 0xbd,BYTE 0x89,BYTE 0xc1,BYTE 0x37,BYTE 0x06,BYTE 0xa4,BYTE 0x13,BYTE 0x2c,BYTE 0xcf,BYTE 0xb1,BYTE 0x6f,BYTE 0x7c,BYTE 0x3b,BYTE 0x9f,BYTE 0xcb]++p2wpkh_script_decodes_as_expected :: H.Assertion+p2wpkh_script_decodes_as_expected = p2wpkh `decodes_to` p2wpkh_terms++-- p2sh-p2wpkh++p2sh_p2wpkh :: BS.ByteString+p2sh_p2wpkh = "a9149c1185a5c5e9fc54612808977ee8f548b2258d3187"++p2sh_p2wpkh_terms :: [Term]+p2sh_p2wpkh_terms = [OPCODE OP_HASH160,OPCODE OP_PUSHBYTES_20,BYTE 0x9c,BYTE 0x11,BYTE 0x85,BYTE 0xa5,BYTE 0xc5,BYTE 0xe9,BYTE 0xfc,BYTE 0x54,BYTE 0x61,BYTE 0x28,BYTE 0x08,BYTE 0x97,BYTE 0x7e,BYTE 0xe8,BYTE 0xf5,BYTE 0x48,BYTE 0xb2,BYTE 0x25,BYTE 0x8d,BYTE 0x31,OPCODE OP_EQUAL]++p2sh_p2wpkh_script_decodes_as_expected :: H.Assertion+p2sh_p2wpkh_script_decodes_as_expected =+ p2sh_p2wpkh `decodes_to` p2sh_p2wpkh_terms++-- p2wsh+p2wsh :: BS.ByteString+p2wsh = "0020e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"++p2wsh_terms :: [Term]+p2wsh_terms = [OPCODE OP_PUSHBYTES_0,OPCODE OP_PUSHBYTES_32,BYTE 0xe3,BYTE 0xb0,BYTE 0xc4,BYTE 0x42,BYTE 0x98,BYTE 0xfc,BYTE 0x1c,BYTE 0x14,BYTE 0x9a,BYTE 0xfb,BYTE 0xf4,BYTE 0xc8,BYTE 0x99,BYTE 0x6f,BYTE 0xb9,BYTE 0x24,BYTE 0x27,BYTE 0xae,BYTE 0x41,BYTE 0xe4,BYTE 0x64,BYTE 0x9b,BYTE 0x93,BYTE 0x4c,BYTE 0xa4,BYTE 0x95,BYTE 0x99,BYTE 0x1b,BYTE 0x78,BYTE 0x52,BYTE 0xb8,BYTE 0x55]++p2wsh_script_decodes_as_expected :: H.Assertion+p2wsh_script_decodes_as_expected = p2wsh `decodes_to` p2wsh_terms++-- p2sh-p2wsh++-- identical to p2sh-p2wpkh at the script level++p2sh_p2wsh :: BS.ByteString+p2sh_p2wsh = "a9149c1185a5c5e9fc54612808977ee8f548b2258d3187"++p2sh_p2wsh_terms :: [Term]+p2sh_p2wsh_terms = [OPCODE OP_HASH160,OPCODE OP_PUSHBYTES_20,BYTE 0x9c,BYTE 0x11,BYTE 0x85,BYTE 0xa5,BYTE 0xc5,BYTE 0xe9,BYTE 0xfc,BYTE 0x54,BYTE 0x61,BYTE 0x28,BYTE 0x08,BYTE 0x97,BYTE 0x7e,BYTE 0xe8,BYTE 0xf5,BYTE 0x48,BYTE 0xb2,BYTE 0x25,BYTE 0x8d,BYTE 0x31,OPCODE OP_EQUAL]++p2sh_p2wsh_script_decodes_as_expected :: H.Assertion+p2sh_p2wsh_script_decodes_as_expected =+ p2sh_p2wsh `decodes_to` p2sh_p2wsh_terms++-- main -----------------------------------------------------------------------++main :: IO ()+main = defaultMain $+ testGroup "ppad-script" [+ testGroup "property tests" [+ testGroup "inverses" [+ Q.testProperty "ba_to_bs . bs_to_ba ~ id" $+ Q.withMaxSuccess 500 ba_to_bs_inverts_bs_to_ba+ , Q.testProperty "ba_to_bs . bs_to_ba ~ id" $+ Q.withMaxSuccess 500 bs_to_ba_inverts_ba_to_bs+ , Q.testProperty "from_base16 . to_base16 ~ id" $+ Q.withMaxSuccess 500 from_base16_inverts_to_base16+ , Q.testProperty "to_base16 . from_base16 ~ id" $+ Q.withMaxSuccess 500 to_base16_inverts_from_base16+ , Q.testProperty "to_script . from_script ~ id" $+ Q.withMaxSuccess 1000 to_script_inverts_from_script+ ]+ ]+ , testGroup "unit tests" [+ H.testCase "p2pkh script decodes to expected terms"+ p2pkh_script_decodes_as_expected+ , H.testCase "p2sh script decodes to expected terms"+ p2sh_script_decodes_as_expected+ , H.testCase "p2wpkh script decodes to expected terms"+ p2wpkh_script_decodes_as_expected+ , H.testCase "p2sh-p2wpkh script decodes to expected terms"+ p2sh_p2wpkh_script_decodes_as_expected+ , H.testCase "p2wsh script decodes to expected terms"+ p2wsh_script_decodes_as_expected+ , H.testCase "p2sh-p2wsh script decodes to expected terms"+ p2sh_p2wsh_script_decodes_as_expected+ ]+ ]+