bitcoin-scripting (empty) → 0.1.0
raw patch · 26 files changed
+2997/−0 lines, 26 filesdep +attoparsecdep +basedep +base16-bytestringsetup-changed
Dependencies added: attoparsec, base, base16-bytestring, bitcoin-scripting, bytestring, cereal, containers, haskoin-core, tasty, tasty-hunit, tasty-quickcheck, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- Setup.hs +2/−0
- bitcoin-scripting.cabal +77/−0
- src/Language/Bitcoin/Miniscript.hs +53/−0
- src/Language/Bitcoin/Miniscript/Compiler.hs +196/−0
- src/Language/Bitcoin/Miniscript/Parser.hs +138/−0
- src/Language/Bitcoin/Miniscript/Syntax.hs +132/−0
- src/Language/Bitcoin/Miniscript/Text.hs +81/−0
- src/Language/Bitcoin/Miniscript/Types.hs +385/−0
- src/Language/Bitcoin/Miniscript/Witness.hs +413/−0
- src/Language/Bitcoin/Script/Descriptors.hs +28/−0
- src/Language/Bitcoin/Script/Descriptors/Parser.hs +99/−0
- src/Language/Bitcoin/Script/Descriptors/Syntax.hs +97/−0
- src/Language/Bitcoin/Script/Descriptors/Text.hs +73/−0
- src/Language/Bitcoin/Script/Utils.hs +49/−0
- src/Language/Bitcoin/Utils.hs +60/−0
- test/Main.hs +9/−0
- test/Test/Descriptors.hs +259/−0
- test/Test/Example.hs +34/−0
- test/Test/Miniscript.hs +48/−0
- test/Test/Miniscript/Compiler.hs +288/−0
- test/Test/Miniscript/Examples.hs +129/−0
- test/Test/Miniscript/Types.hs +83/−0
- test/Test/Miniscript/Witness.hs +196/−0
- test/Test/Utils.hs +34/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for bitcoin-scripting ++## 0.1.0++First release
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020-present, Bitnomial, Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bitcoin-scripting.cabal view
@@ -0,0 +1,77 @@+cabal-version: 2.4+name: bitcoin-scripting+version: 0.1.0+synopsis: Resources for working with miniscript, and script descriptors+homepage: https://github.com/bitnomial/bitcoin-scripting+copyright: 2020 Bitnomial, Inc.+license: BSD-3-Clause+license-file: LICENSE+author: Ian Shipman+maintainer: ics@gambolingpangolin.com+category: Language+build-type: Simple+extra-source-files: CHANGELOG.md++tested-with: GHC == 8.8.4++common base+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.12 && <4.15+ , base16-bytestring <1.0+ -- ^^ Needed because of missing upper bound in haskoin-core+ , bytestring >=0.10 && <0.12+ , cereal ^>=0.5+ , haskoin-core >=0.15 && <0.18+ , text >=1.2 && <1.3++library+ import: base+ hs-source-dirs: src++ exposed-modules:+ Language.Bitcoin.Miniscript+ Language.Bitcoin.Miniscript.Witness+ Language.Bitcoin.Script.Descriptors+ Language.Bitcoin.Script.Utils++ other-modules:+ Language.Bitcoin.Miniscript.Compiler+ Language.Bitcoin.Miniscript.Parser+ Language.Bitcoin.Miniscript.Text+ Language.Bitcoin.Miniscript.Syntax+ Language.Bitcoin.Miniscript.Types++ Language.Bitcoin.Script.Descriptors.Parser+ Language.Bitcoin.Script.Descriptors.Syntax+ Language.Bitcoin.Script.Descriptors.Text++ Language.Bitcoin.Utils++ build-depends:+ attoparsec ^>=0.13+ , containers ^>=0.6+ , transformers ^>=0.5++test-suite bitcoin-scripting-tests+ import: base+ type: exitcode-stdio-1.0+ hs-source-dirs: test/+ main-is: Main.hs++ other-modules:+ Test.Descriptors+ Test.Example+ Test.Miniscript+ Test.Miniscript.Compiler+ Test.Miniscript.Examples+ Test.Miniscript.Types+ Test.Miniscript.Witness+ Test.Utils++ build-depends:+ bitcoin-scripting+ , tasty >=1.0 && <1.5+ , tasty-hunit >=0.9 && <0.11+ , tasty-quickcheck >=0.8.1 && <0.11
+ src/Language/Bitcoin/Miniscript.hs view
@@ -0,0 +1,53 @@+{- |+ Module: Language.Bitcoin.Miniscript++ Haskell embedding of miniscript. See http://bitcoin.sipa.be/miniscript/ for+ details. Much of the documentation below is taken from this site.+-}+module Language.Bitcoin.Miniscript (+ -- * Syntax tree+ Value (..),+ var,+ literal,+ Miniscript (..),+ let_,+ key,+ keyH,+ older,+ after,+ sha256,+ ripemd160,+ hash256,+ hash160,+ thresh,+ multi,+ MiniscriptAnnotation (..),+ Annotation (..),++ -- * Type system+ BaseType (..),+ ModField (..),+ MiniscriptType (..),+ boolType,+ numberType,+ bytesType,+ keyDescriptorType,+ typeCheckMiniscript,+ MiniscriptTypeError (..),++ -- * Compilation+ compile,+ compileOnly,+ CompilerError (..),++ -- * Printing and parsing+ miniscriptToText,+ miniscriptParser,+ parseMiniscript,+) where++import Language.Bitcoin.Miniscript.Compiler+import Language.Bitcoin.Miniscript.Parser+import Language.Bitcoin.Miniscript.Syntax+import Language.Bitcoin.Miniscript.Text+import Language.Bitcoin.Miniscript.Types
+ src/Language/Bitcoin/Miniscript/Compiler.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Compile miniscript into bitcoin script+module Language.Bitcoin.Miniscript.Compiler (+ CompilerError (..),+ compile,+ compileOnly,+) where++import Control.Exception (Exception)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (Except, runExcept, throwE)+import Control.Monad.Trans.Reader (+ ReaderT,+ local,+ runReaderT,+ )+import Data.Bifunctor (first)+import Data.Functor (void)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Serialize (encode)+import Data.Text (Text)+import Haskoin.Crypto (ripemd160)+import Haskoin.Script (+ Script (..),+ ScriptOp (..),+ opPushData,+ )++import Language.Bitcoin.Miniscript.Syntax (+ Miniscript (..),+ Value (..),+ )+import Language.Bitcoin.Miniscript.Types (+ MiniscriptTypeError (..),+ typeCheckMiniscript,+ )+import Language.Bitcoin.Script.Descriptors (KeyDescriptor, keyBytes)+import Language.Bitcoin.Script.Utils (pushNumber)+import Language.Bitcoin.Utils (requiredContextValue)++data CompilerError+ = FreeVariable Text+ | CompilerError Miniscript+ | TypeError MiniscriptTypeError+ | NotImplemented Miniscript+ | AbstractKey KeyDescriptor+ deriving (Eq, Show)++instance Exception CompilerError++-- | Type check and compile a miniscript+compile :: Miniscript -> Either CompilerError Script+compile script = do+ void . first TypeError $ typeCheckMiniscript mempty script+ compileOnly script++-- | Compile a miniscript without type checking+compileOnly :: Miniscript -> Either CompilerError Script+compileOnly = fmap Script . runExcept . (`runReaderT` Context mempty) . compileOpsInContext++newtype Context = Context {unContext :: Map Text (Context, Miniscript)}++addClosure :: Text -> Miniscript -> Context -> Context+addClosure n e c = Context . Map.insert n (c, e) $ unContext c++requiredScript :: Text -> ReaderT Context (Except CompilerError) (Context, Miniscript)+requiredScript name = requiredContextValue unContext (FreeVariable name) name++compileOpsInContext :: Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]+compileOpsInContext = \case+ Boolean x -> return $ if x then [OP_1] else [OP_0]+ Key vk -> getKeyScript vk+ KeyH vk -> do+ k <- getKeyBytes =<< requiredKey vk+ return [OP_DUP, OP_HASH160, opPushData (encode $ ripemd160 k), OP_EQUALVERIFY]+ Older vn -> do+ n <- requiredNumber vn+ return [pushNumber n, OP_CHECKSEQUENCEVERIFY]+ After vn -> do+ n <- requiredNumber vn+ return [pushNumber n, OP_CHECKLOCKTIMEVERIFY]+ Sha256 vb -> do+ b <- requiredBytes vb+ return $ sizeCheck <> [OP_SHA256, opPushData b, OP_EQUAL]+ Ripemd160 vb -> do+ b <- requiredBytes vb+ return $ sizeCheck <> [OP_RIPEMD160, opPushData b, OP_EQUAL]+ Hash256 vb -> do+ b <- requiredBytes vb+ return $ sizeCheck <> [OP_HASH256, opPushData b, OP_EQUAL]+ Hash160 vb -> do+ b <- requiredBytes vb+ return $ sizeCheck <> [OP_HASH160, opPushData b, OP_EQUAL]+ AndOr x y z -> do+ opsX <- compileOpsInContext x+ opsY <- compileOpsInContext y+ opsZ <- compileOpsInContext z+ return $ mconcat [opsX, pure OP_NOTIF, opsZ, pure OP_ELSE, opsY, pure OP_ENDIF]+ AndV x z -> do+ opsX <- compileOpsInContext x+ opsZ <- compileOpsInContext z+ return $ opsX <> opsZ+ AndB x z -> do+ opsX <- compileOpsInContext x+ opsZ <- compileOpsInContext z+ return $ opsX <> opsZ <> [OP_BOOLAND]+ OrB x z -> do+ opsX <- compileOpsInContext x+ opsZ <- compileOpsInContext z+ return $ opsX <> opsZ <> [OP_BOOLOR]+ OrC x z -> do+ opsX <- compileOpsInContext x+ opsZ <- compileOpsInContext z+ return $ mconcat [opsX, pure OP_NOTIF, opsZ, pure OP_ENDIF]+ OrD x z -> do+ opsX <- compileOpsInContext x+ opsZ <- compileOpsInContext z+ return $ mconcat [opsX, [OP_IFDUP, OP_NOTIF], opsZ, pure OP_ENDIF]+ OrI x z -> do+ opsX <- compileOpsInContext x+ opsZ <- compileOpsInContext z+ return $ mconcat [pure OP_IF, opsX, pure OP_ELSE, opsZ, pure OP_ENDIF]+ Thresh vk x xs -> do+ k <- requiredNumber vk+ opsX <- compileOpsInContext x+ opsXS <- traverse compileOpsInContext xs+ return . mconcat $ pure opsX <> concatMap addX opsXS <> [[pushNumber k, OP_EQUAL]]+ where+ addX ops = [ops, pure OP_ADD]+ Multi vk xs -> do+ k <- requiredNumber vk+ opsXS <- traverse getKeyScript xs+ return . mconcat $ pure [pushNumber k] <> opsXS <> pure [pushNumber (length xs), OP_CHECKMULTISIG]+ AnnA x -> annA <$> compileOpsInContext x+ where+ annA ops = OP_TOALTSTACK : ops <> [OP_FROMALTSTACK]+ AnnS x -> (OP_SWAP :) <$> compileOpsInContext x+ AnnC x -> (<> [OP_CHECKSIG]) <$> compileOpsInContext x+ AnnD x -> annD <$> compileOpsInContext x+ where+ annD ops = [OP_DUP, OP_IF] <> ops <> [OP_ENDIF]+ AnnV x -> annV <$> compileOpsInContext x+ where+ annV ops =+ let (ops', op) = unsnoc ops+ in case op of+ OP_EQUAL -> ops' <> [OP_EQUALVERIFY]+ OP_NUMEQUAL -> ops' <> [OP_NUMEQUALVERIFY]+ OP_CHECKSIG -> ops' <> [OP_CHECKSIGVERIFY]+ OP_CHECKMULTISIG -> ops' <> [OP_CHECKMULTISIGVERIFY]+ _ -> ops <> [OP_VERIFY]+ AnnJ x -> annJ <$> compileOpsInContext x+ where+ annJ ops = [OP_SIZE, OP_0NOTEQUAL, OP_IF] <> ops <> [OP_ENDIF]+ AnnN x -> (<> [OP_0NOTEQUAL]) <$> compileOpsInContext x+ Var n -> do+ (c', s) <- requiredScript n+ local (const c') $ compileOpsInContext s+ Let n e b -> local (addClosure n e) $ compileOpsInContext b+ Number x -> return [pushNumber x]+ Bytes b -> return [opPushData b]+ KeyDesc k | Just b <- keyBytes k -> return [opPushData b]+ e@KeyDesc{} -> typeError e+ where+ sizeCheck = [OP_SIZE, pushNumber 32, OP_EQUALVERIFY]+ typeError = lift . throwE . TypeError . MiniscriptTypeError++ required f = \case+ Lit x -> return x+ Variable n -> requiredScript n >>= f . snd++ requiredNumber = required $ \case+ Number x -> return x+ e -> typeError e++ getKeyScript vk = fmap (pure . opPushData) $ requiredKey vk >>= getKeyBytes++ requiredKey = required $ \case+ KeyDesc k -> return k+ e -> typeError e++ getKeyBytes k+ | Just b <- keyBytes k = return b+ | otherwise = lift . throwE $ AbstractKey k++ requiredBytes = required $ \case+ Bytes b -> return b+ e -> typeError e++unsnoc :: [a] -> ([a], a)+unsnoc [] = error "unsnoc: empty list"+unsnoc [x] = ([], x)+unsnoc (x : xs) = let (zs, z) = unsnoc xs in (x : zs, z)
+ src/Language/Bitcoin/Miniscript/Parser.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Bitcoin.Miniscript.Parser (+ miniscriptParser,+ parseMiniscript,+) where++import Control.Applicative ((<|>))+import Control.Monad (void)+import Data.Attoparsec.Text (Parser)+import qualified Data.Attoparsec.Text as A+import Data.Text (Text, pack)+import Haskoin.Constants (Network)++import Language.Bitcoin.Miniscript.Syntax (+ Miniscript (..),+ Value (..),+ )+import Language.Bitcoin.Script.Descriptors (keyDescriptorParser)+import Language.Bitcoin.Utils (+ alphanum,+ application,+ argList,+ comma,+ hex,+ spacePadded,+ )++parseMiniscript :: Network -> Text -> Either String Miniscript+parseMiniscript net = A.parseOnly $ miniscriptParser net++miniscriptParser :: Network -> Parser Miniscript+miniscriptParser net = annotP expression <|> expression+ where+ expression =+ keyP <|> keyCP <|> keyHP <|> keyHCP <|> olderP <|> afterP+ <|> sha256P+ <|> ripemd160P+ <|> hash256P+ <|> hash160P+ <|> andOrP+ <|> andVP+ <|> andBP+ <|> orBP+ <|> orCP+ <|> orDP+ <|> orIP+ <|> threshP+ <|> multiP+ <|> numberP+ <|> trueP+ <|> falseP+ <|> bytesP+ <|> keyDescriptorP+ <|> letP+ <|> varP++ trueP = Boolean True <$ A.char '1'+ falseP = Boolean False <$ A.char '0'++ numberP = Number <$> A.decimal+ bytesP = Bytes <$> hex++ keyDescriptorP = KeyDesc <$> keyDescriptorParser net++ keyP = Key <$> application "pk_k" atomicKeyDescP+ keyCP = AnnC . Key <$> application "pk" atomicKeyDescP++ keyHP = KeyH <$> application "pk_h" atomicKeyDescP+ keyHCP = AnnC . KeyH <$> application "pkh" atomicKeyDescP++ olderP = Older <$> application "older" atomicNumberP+ afterP = After <$> application "after" atomicNumberP++ sha256P = Sha256 <$> application "sha256" atomicBytesP+ ripemd160P = Ripemd160 <$> application "ripemd160" atomicBytesP+ hash256P = Hash256 <$> application "hash256" atomicBytesP+ hash160P = Hash160 <$> application "hash160" atomicBytesP++ andOrP =+ application "andor" $+ AndOr <$> mp+ <*> comma mp+ <*> comma mp++ andVP = application "and_v" $ AndV <$> mp <*> comma mp+ andBP = application "and_b" $ AndB <$> mp <*> comma mp+ orBP = application "or_b" $ OrB <$> mp <*> comma mp+ orCP = application "or_c" $ OrC <$> mp <*> comma mp+ orDP = application "or_d" $ OrD <$> mp <*> comma mp+ orIP = application "or_i" $ OrI <$> mp <*> comma mp++ varP = Var <$> varIdentP+ varIdentP = pack <$> A.many' (alphanum <|> A.char '_')++ letP = do+ void $ A.string "let"+ Let <$> spacePadded varIdentP+ <*> (A.char '=' >> spacePadded mp)+ <*> (A.string "in" >> spacePadded mp)++ threshP =+ application "thresh" $+ Thresh <$> atomicNumberP <*> comma mp <*> comma (argList mp)++ multiP =+ application "multi" $+ Multi <$> atomicNumberP <*> comma (argList atomicKeyDescP)++ atomicNumberP = (Lit <$> A.decimal) <|> (Variable <$> varIdentP)+ atomicBytesP = (Lit <$> hex) <|> (Variable <$> varIdentP)+ atomicKeyDescP = (Lit <$> keyDescriptorParser net) <|> (Variable <$> varIdentP)++ annotP p = do+ anns <- calcAnnotation <$> annPrefixP+ anns <$> p++ annPrefixP = A.many' (spacePadded $ A.satisfy isAnn) <* spacePadded (A.char ':')++ calcAnnotation = flip $ foldr toAnn++ toAnn = \case+ 'a' -> AnnA+ 's' -> AnnS+ 'c' -> AnnC+ 'd' -> AnnD+ 'v' -> AnnV+ 'j' -> AnnJ+ 'n' -> AnnN+ 't' -> (`AndV` Boolean True)+ 'l' -> OrI (Boolean False)+ 'u' -> (`OrI` Boolean False)+ _ -> error "unexpected annotation"++ isAnn = A.inClass "asctdvjnlu"++ mp = miniscriptParser net
+ src/Language/Bitcoin/Miniscript/Syntax.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE LambdaCase #-}++{- |+ Module: Language.Bitcoin.Miniscript.Syntax++ Haskell embedding of miniscript. See http://bitcoin.sipa.be/miniscript/ for+ details. Much of the documentation below is taken from this site.+-}+module Language.Bitcoin.Miniscript.Syntax (+ Value (..),+ var,+ literal,+ Miniscript (..),+ let_,+ key,+ keyH,+ older,+ after,+ sha256,+ ripemd160,+ hash256,+ hash160,+ thresh,+ multi,+ Annotation (..),+ MiniscriptAnnotation (..),+) where++import Data.ByteString (ByteString)+import Data.Foldable (foldr')+import Data.Text (Text)++import Language.Bitcoin.Script.Descriptors (KeyDescriptor)++data Value a = Variable Text | Lit a+ deriving (Eq, Show, Ord)++var :: Text -> Value a+var = Variable++literal :: a -> Value a+literal = Lit++-- | The Miniscript AST with the addition of key descriptors and let bindings+data Miniscript+ = Var Text+ | Let Text Miniscript Miniscript+ | Boolean Bool+ | Number Int+ | Bytes ByteString+ | KeyDesc KeyDescriptor+ | Key (Value KeyDescriptor)+ | KeyH (Value KeyDescriptor)+ | Older (Value Int)+ | After (Value Int)+ | Sha256 (Value ByteString)+ | Ripemd160 (Value ByteString)+ | Hash256 (Value ByteString)+ | Hash160 (Value ByteString)+ | AndOr Miniscript Miniscript Miniscript+ | AndV Miniscript Miniscript+ | AndB Miniscript Miniscript+ | OrB Miniscript Miniscript+ | OrC Miniscript Miniscript+ | OrD Miniscript Miniscript+ | OrI Miniscript Miniscript+ | Thresh (Value Int) Miniscript [Miniscript]+ | Multi (Value Int) [Value KeyDescriptor]+ | AnnA Miniscript+ | AnnS Miniscript+ | AnnC Miniscript+ | AnnD Miniscript+ | AnnV Miniscript+ | AnnJ Miniscript+ | AnnN Miniscript+ deriving (Eq, Show)++-- | Check a key+key :: KeyDescriptor -> Miniscript+key = AnnC . Key . literal++-- | Check a key hash+keyH :: KeyDescriptor -> Miniscript+keyH = AnnC . KeyH . literal++older :: Int -> Miniscript+older = Older . literal++after :: Int -> Miniscript+after = After . literal++sha256 :: ByteString -> Miniscript+sha256 = Sha256 . literal++ripemd160 :: ByteString -> Miniscript+ripemd160 = Ripemd160 . literal++hash256 :: ByteString -> Miniscript+hash256 = Hash256 . literal++hash160 :: ByteString -> Miniscript+hash160 = Hash160 . literal++thresh :: Int -> Miniscript -> [Miniscript] -> Miniscript+thresh k = Thresh (Lit k)++multi :: Int -> [KeyDescriptor] -> Miniscript+multi k ks = Multi (literal k) $ literal <$> ks++let_ :: [(Text, Miniscript)] -> Miniscript -> Miniscript+let_ = flip . foldr' $ uncurry Let++class MiniscriptAnnotation a where+ (.:) :: a -> Miniscript -> Miniscript++data Annotation = A | S | C | D | V | J | N | T | L | U deriving (Eq, Show, Ord, Enum)++instance MiniscriptAnnotation Annotation where+ (.:) = \case+ A -> AnnA+ S -> AnnS+ C -> AnnC+ D -> AnnD+ V -> AnnV+ J -> AnnJ+ N -> AnnN+ T -> (`AndV` Boolean True)+ L -> OrI $ Boolean True+ U -> (`OrI` Boolean False)++instance MiniscriptAnnotation a => MiniscriptAnnotation [a] where+ (.:) = flip $ foldr' (.:)
+ src/Language/Bitcoin/Miniscript/Text.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Produce a text representation of Miniscript expressions+module Language.Bitcoin.Miniscript.Text (+ miniscriptToText,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import Haskoin.Constants (Network)+import Haskoin.Util (encodeHex)++import Language.Bitcoin.Miniscript.Syntax (+ Miniscript (..),+ Value (..),+ )+import Language.Bitcoin.Script.Descriptors (keyDescriptorToText)+import Language.Bitcoin.Utils (applicationText, showText)++miniscriptToText :: Network -> Miniscript -> Text+miniscriptToText net = \case+ Var n -> n+ Let n e b ->+ "let " <> n <> " = " <> miniscriptToText net e <> " in " <> miniscriptToText net b+ Boolean True -> "1"+ Boolean False -> "0"+ Number w -> showText w+ Bytes b -> encodeHex b+ KeyDesc k -> keyDescriptorToText net k+ Key x -> applicationText "pk_k" $ atomicKeyDescText x+ KeyH x -> applicationText "pk_h" $ atomicKeyDescText x+ Older n -> applicationText "older" $ atomicNumberText n+ After n -> applicationText "after" $ atomicNumberText n+ Sha256 h -> applicationText "sha256" $ atomicBytesText h+ Ripemd160 h -> applicationText "ripemd160" $ atomicBytesText h+ Hash256 h -> applicationText "hash256" $ atomicBytesText h+ Hash160 h -> applicationText "hash160" $ atomicBytesText h+ AndV x (Boolean True) -> "t:" <> toText x+ OrI (Boolean False) x -> "l:" <> toText x+ OrI x (Boolean False) -> "u:" <> toText x+ AndOr x y z -> applicationText "andor" $ printList [x, y, z]+ AndV x y -> applicationText "and_v" $ printList [x, y]+ AndB x y -> applicationText "and_b" $ printList [x, y]+ OrB x y -> applicationText "or_b" $ printList [x, y]+ OrC x y -> applicationText "or_c" $ printList [x, y]+ OrD x y -> applicationText "or_d" $ printList [x, y]+ OrI x y -> applicationText "or_i" $ printList [x, y]+ Thresh k x xs ->+ applicationText "thresh" . Text.intercalate "," $ atomicNumberText k : (toText <$> (x : xs))+ Multi n xs ->+ applicationText "multi" . Text.intercalate "," $ atomicNumberText n : (atomicKeyDescText <$> xs)+ a -> ann "" a+ where+ ann as = \case+ AnnC (Key x) -> printAnn as $ applicationText "pk" $ atomicKeyDescText x+ AnnC (KeyH x) -> printAnn as $ applicationText "pkh" $ atomicKeyDescText x+ AnnA x -> ann ('a' : as) x+ AnnS x -> ann ('s' : as) x+ AnnC x -> ann ('c' : as) x+ AnnD x -> ann ('d' : as) x+ AnnV x -> ann ('v' : as) x+ AnnJ x -> ann ('j' : as) x+ AnnN x -> ann ('n' : as) x+ e -> printAnn as $ toText e++ printAnn as x+ | null as = x+ | otherwise = Text.pack (reverse as) <> ":" <> x++ printList = Text.intercalate "," . fmap toText++ toText = miniscriptToText net++ atomicNumberText = atomicText showText+ atomicBytesText = atomicText encodeHex+ atomicKeyDescText = atomicText (keyDescriptorToText net)++ atomicText f = \case+ Variable name -> name+ Lit x -> f x
+ src/Language/Bitcoin/Miniscript/Types.hs view
@@ -0,0 +1,385 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Types and type checking+module Language.Bitcoin.Miniscript.Types (+ BaseType (..),+ ModField (..),+ MiniscriptType (..),+ boolType,+ numberType,+ bytesType,+ keyDescriptorType,+ typeCheckMiniscript,+ MiniscriptTypeError (..),+) where++import Control.Monad (unless)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (Except, runExcept, throwE)+import Control.Monad.Trans.Reader (ReaderT, local, runReaderT)+import Data.Bool (bool)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)++import Language.Bitcoin.Miniscript.Syntax (+ Miniscript (..),+ Value (..),+ )+import Language.Bitcoin.Utils (requiredContextValue)++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++data BaseType+ = -- | Base expression+ TypeB+ | -- | Verify expression+ TypeV+ | -- | Key expression+ TypeK+ | -- | Wrapped expression+ TypeW+ | -- | Number expression+ TypeNumber+ | -- | Bytes expression+ TypeBytes+ | -- | Key descriptor type+ TypeKeyDesc+ deriving (Eq, Show)++notW :: BaseType -> Bool+notW = (/= TypeW)++-- | Type modifications that imply additional properties of the expression+data ModField = ModField+ { -- | Consumes exactly 0 stack elements+ modZ :: Bool+ , -- | One-arg: this expression always consumes exactly 1 stack element.+ modO :: Bool+ , -- | Nonzero: this expression always consumes at least 1 stack element, no+ -- satisfaction for this expression requires the top input stack element to+ -- be zero.+ modN :: Bool+ , -- | Dissatisfiable: a dissatisfaction for this expression can+ -- unconditionally be constructed.+ modD :: Bool+ , -- | Unit: when satisfied put exactly 1 on the stack+ modU :: Bool+ }+ deriving (Eq, Show)++data MiniscriptType = MiniscriptType+ { baseType :: BaseType+ , modifiers :: ModField+ }+ deriving (Eq, Show)++emptyModField :: ModField+emptyModField = ModField False False False False False++boolType :: Bool -> MiniscriptType+boolType = MiniscriptType TypeB . bool falseMods trueMods+ where+ trueMods = emptyModField{modZ = True, modU = True}+ falseMods = emptyModField{modZ = True, modU = True, modD = True}++numberType :: MiniscriptType+numberType = MiniscriptType TypeNumber emptyModField++bytesType :: MiniscriptType+bytesType = MiniscriptType TypeBytes emptyModField++keyDescriptorType :: MiniscriptType+keyDescriptorType = MiniscriptType TypeKeyDesc emptyModField++data MiniscriptTypeError+ = MiniscriptTypeError Miniscript+ | UntypedVariable Text+ | -- | fields: @name expectedBaseType typeAnnotation@+ WrongVariableType Text BaseType MiniscriptType+ deriving (Eq, Show)++type TypeCheckM a = ReaderT (Map Text MiniscriptType) (Except MiniscriptTypeError) a++requiredVarType :: Text -> TypeCheckM MiniscriptType+requiredVarType name = requiredContextValue id (UntypedVariable name) name++-- | Check that a miniscript expression is well-typed.+typeCheckMiniscript ::+ -- | type hints for free variables in the miniscript expression+ Map Text MiniscriptType ->+ Miniscript ->+ Either MiniscriptTypeError MiniscriptType+typeCheckMiniscript context = runExcept . (`runReaderT` context) . typeCheckInContext++typeCheckInContext :: Miniscript -> TypeCheckM MiniscriptType+typeCheckInContext = \case+ Var name -> requiredVarType name+ Let name expr body -> do+ ty <- typeCheckInContext expr+ local (Map.insert name ty) $ typeCheckInContext body+ Boolean b -> return $ boolType b+ Number{} -> return numberType+ Bytes{} -> return bytesType+ KeyDesc{} -> return keyDescriptorType+ Key x -> ondu TypeK <$ literal TypeKeyDesc x+ KeyH x -> ndu TypeK <$ literal TypeKeyDesc x+ Older x -> literal TypeNumber x >> exprType TypeB emptyModField{modZ = True}+ After x -> literal TypeNumber x >> exprType TypeB emptyModField{modZ = True}+ Sha256 x -> ondu TypeB <$ literal TypeBytes x+ Ripemd160 x -> ondu TypeB <$ literal TypeBytes x+ Hash256 x -> ondu TypeB <$ literal TypeBytes x+ Hash160 x -> ondu TypeB <$ literal TypeBytes x+ e@(AndOr x y z) -> do+ tx <- typeCheckInContext x+ ty <- typeCheckInContext y+ tz <- typeCheckInContext z++ let mx = modifiers tx+ my = modifiers ty+ mz = modifiers tz++ bty = baseType ty++ if (baseType tx == TypeB) && (baseType tz == bty) && notW bty && modD mx && modU mx+ then+ exprType+ bty+ emptyModField+ { modZ = modZ mx && modZ my && modZ mz+ , modO = (modZ mx && modO my && modO mz) || (modO mx && modZ my && modZ mz)+ , modU = modU my && modU mz+ , modD = modD mz+ }+ else typeError e+ e@(AndV x y) -> do+ tx <- typeCheckInContext x+ ty <- typeCheckInContext y+ let mx = modifiers tx+ my = modifiers ty+ bty = baseType ty+ if baseType tx == TypeV && notW bty+ then+ exprType+ bty+ emptyModField+ { modZ = modZ mx && modZ my+ , modO = (modZ mx && modO my) || (modO mx && modZ my)+ , modN = modN mx || (modZ mx && modN my)+ , modU = modU my+ }+ else typeError e+ e@(AndB x y) -> do+ tx <- typeCheckInContext x+ ty <- typeCheckInContext y+ let mx = modifiers tx+ my = modifiers ty+ if baseType tx == TypeB && baseType ty == TypeW+ then+ exprType+ TypeB+ emptyModField+ { modZ = modZ mx && modZ my+ , modO = (modZ mx && modO my) || (modO mx && modZ my)+ , modN = modN mx || (modZ mx && modN my)+ , modD = modD mx && modD my+ , modU = True+ }+ else typeError e+ e@(OrB x z) -> do+ tx <- typeCheckInContext x+ tz <- typeCheckInContext z+ let mx = modifiers tx+ mz = modifiers tz+ if baseType tx == TypeB && baseType tz == TypeW && modD mx && modD mz+ then+ exprType+ TypeB+ emptyModField+ { modZ = modZ mx && modZ mz+ , modO =+ (modZ mx && modO mz)+ || (modO mx && modZ mz)+ , modD = True+ , modU = True+ }+ else typeError e+ e@(OrC x z) -> do+ tx <- typeCheckInContext x+ tz <- typeCheckInContext z+ let mx = modifiers tx+ mz = modifiers tz+ if baseType tx == TypeB && baseType tz == TypeV && modD mx && modU mx+ then+ exprType+ TypeV+ emptyModField+ { modZ = modZ mx && modZ mz+ , modO = modO mx && modZ mz+ }+ else typeError e+ e@(OrD x z) -> do+ tx <- typeCheckInContext x+ tz <- typeCheckInContext z+ let mx = modifiers tx+ mz = modifiers tz+ if baseType tx == TypeB && baseType tz == TypeB && modD mx && modU mx+ then+ exprType+ TypeB+ emptyModField+ { modZ = modZ mx && modZ mz+ , modO = modO mx && modZ mz+ , modD = modD mz+ , modU = modU mz+ }+ else typeError e+ e@(OrI x z) -> do+ tx <- typeCheckInContext x+ tz <- typeCheckInContext z+ let mx = modifiers tx+ mz = modifiers tz+ btx = baseType tx+ if (baseType tz == btx) && notW btx+ then+ exprType+ btx+ emptyModField+ { modO = modZ mx && modZ mz+ , modD = modD mx || modD mz+ , modU = modU mx && modU mz+ }+ else typeError e+ e@(Thresh k x ys) -> do+ literal TypeNumber k+ tx <- typeCheckInContext x+ tys <- traverse typeCheckInContext ys+ let mx = modifiers tx+ mys = modifiers <$> tys+ allMods = mx : mys+ zCount = count modZ allMods+ oCount = count modO allMods :: Int+ count f = sum . fmap (bool 0 1 . f)+ isDU m = modD m && modU m++ if baseType tx == TypeB && all (== TypeW) (baseType <$> tys) && all isDU allMods+ then+ exprType+ TypeB+ emptyModField+ { modZ = all modZ allMods+ , modO = zCount == length ys && oCount == 1+ , modD = True+ , modU = True+ }+ else typeError e+ Multi k ks -> do+ literal TypeNumber k+ mapM_ (literal TypeKeyDesc) ks+ return $ ndu TypeB+ e@(AnnA x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeB+ then+ exprType+ TypeW+ emptyModField+ { modD = modD mx+ , modU = modU mx+ }+ else typeError e+ e@(AnnS x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeB && modO mx+ then+ exprType+ TypeW+ emptyModField+ { modD = modD mx+ , modU = modU mx+ }+ else typeError e+ e@(AnnC x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeK+ then+ exprType+ TypeB+ emptyModField+ { modO = modO mx+ , modN = modN mx+ , modD = modD mx+ , modU = True+ }+ else typeError e+ e@(AnnD x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeV && modZ mx+ then+ exprType+ TypeB+ emptyModField+ { modO = modZ mx+ , modN = True+ , modU = True+ , modD = True+ }+ else typeError e+ e@(AnnV x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeB+ then+ exprType+ TypeV+ emptyModField+ { modZ = modZ mx+ , modO = modO mx+ , modN = modN mx+ }+ else typeError e+ e@(AnnJ x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeB && modN mx+ then+ exprType+ TypeB+ emptyModField+ { modO = modO mx+ , modN = True+ , modD = True+ , modU = modU mx+ }+ else typeError e+ e@(AnnN x) -> do+ tx <- typeCheckInContext x+ let mx = modifiers tx+ if baseType tx == TypeB+ then+ exprType+ TypeB+ emptyModField+ { modZ = modZ mx+ , modO = modO mx+ , modN = modN mx+ , modD = modD mx+ , modU = True+ }+ else typeError e+ where+ ondu = flip MiniscriptType emptyModField{modO = True, modN = True, modD = True, modU = True}+ ndu = flip MiniscriptType emptyModField{modN = True, modD = True, modU = True}++ exprType t = return . MiniscriptType t+ typeError = lift . throwE . MiniscriptTypeError++ literal bt (Variable n) = do+ t' <- requiredVarType n+ unless (baseType t' == bt) . lift . throwE $ WrongVariableType n bt t'+ literal _ _ = return ()
+ src/Language/Bitcoin/Miniscript/Witness.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Bitcoin.Miniscript.Witness (+ satisfy,+ SatisfactionContext,+ satisfactionContext,+ signature,+ preimage,+ lookupSignature,+ lookupPreimage,+ ChainState (..),+ emptyChainState,+ Signature (..),+ SatisfactionError (..),+) where++import Control.Exception (Exception)+import Control.Monad.Trans.Reader (+ Reader,+ asks,+ local,+ runReader,+ )+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Either (rights)+import Data.Function (on)+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, mapMaybe)+import Data.Serialize (encode)+import Data.Text (Text)+import Haskoin.Crypto (Sig)+import Haskoin.Keys (+ PubKeyI (..),+ exportPubKey,+ )+import Haskoin.Script (+ Script (..),+ ScriptOp (..),+ SigHash,+ TxSignature (..),+ encodeTxSig,+ opPushData,+ )++import Language.Bitcoin.Miniscript.Syntax (+ Miniscript (..),+ Value (..),+ )+import Language.Bitcoin.Script.Descriptors (+ KeyDescriptor,+ keyDescPubKey,+ )++data Signature = Signature+ { sig :: !Sig+ , sigHash :: !SigHash+ }+ deriving (Eq, Show)++newtype OrdPubKeyI = OrdPubKeyI {unOrdPubKeyI :: PubKeyI}+ deriving (Eq, Show)++instance Ord OrdPubKeyI where+ compare = compare `on` toOrdered . unOrdPubKeyI+ where+ toOrdered (PubKeyI pk c) = exportPubKey c pk++data SatisfactionContext = SatisfactionContext+ { signatures :: Map OrdPubKeyI Signature+ , hashPreimages :: Map ByteString ByteString+ }+ deriving (Eq, Show)++instance Semigroup SatisfactionContext where+ icA <> icB =+ SatisfactionContext+ { signatures = signatures icA <> signatures icB+ , hashPreimages = hashPreimages icA <> hashPreimages icB+ }++instance Monoid SatisfactionContext where+ mempty = SatisfactionContext mempty mempty++-- | Use with the monoid instance to add a signature to the 'SatisfactionContext'+signature :: PubKeyI -> Signature -> SatisfactionContext+signature pk = (`SatisfactionContext` mempty) . Map.singleton (OrdPubKeyI pk)++-- | Use with the monoid instance to add preimage to the 'SatisfactionContext'+preimage ::+ -- | hash+ ByteString ->+ -- | preimage+ ByteString ->+ SatisfactionContext+preimage h = SatisfactionContext mempty . Map.singleton h++satisfactionContext :: [(ByteString, ByteString)] -> [(PubKeyI, Signature)] -> SatisfactionContext+satisfactionContext preimages sigs =+ SatisfactionContext+ { signatures = Map.fromList $ first OrdPubKeyI <$> sigs+ , hashPreimages = Map.fromList preimages+ }++lookupSignature :: PubKeyI -> SatisfactionContext -> Maybe Signature+lookupSignature pk = Map.lookup (OrdPubKeyI pk) . signatures++lookupPreimage :: ByteString -> SatisfactionContext -> Maybe ByteString+lookupPreimage h = Map.lookup h . hashPreimages++data ChainState = ChainState+ { blockHeight :: Maybe Int+ , utxoAge :: Maybe Int+ }+ deriving (Eq, Show)++emptyChainState :: ChainState+emptyChainState = ChainState Nothing Nothing++data SatisfactionError+ = MissingSignature [KeyDescriptor]+ | MissingPreimage ByteString+ | FreeVariable Text+ | TypeError Text Miniscript+ | Impossible+ | AbstractKey KeyDescriptor+ deriving (Eq, Show)++instance Exception SatisfactionError++data SatScript = SatScript+ { satWeight :: Int+ , satScript :: [ScriptOp]+ }+ deriving (Eq, Show)++instance Semigroup SatScript where+ SatScript n0 s0 <> SatScript n1 s1 = SatScript (n0 + n1) (s0 <> s1)++instance Monoid SatScript where+ mempty = SatScript 0 mempty++fromScript :: [ScriptOp] -> SatScript+fromScript s = SatScript (BS.length $ encode s) s++data SatResult = SatResult+ { sat :: Either SatisfactionError SatScript+ , dsat :: Either SatisfactionError SatScript+ }+ deriving (Eq, Show)++-- | Compute a scriptinput which satisfies this miniscript+satisfy :: ChainState -> SatisfactionContext -> Miniscript -> Either SatisfactionError Script+satisfy chainState sc = fmap (Script . satScript) . sat . (`runReader` mempty) . satisfy' chainState sc++satisfy' :: ChainState -> SatisfactionContext -> Miniscript -> Reader (Map Text Miniscript) SatResult+satisfy' chainState sc = \case+ Boolean False ->+ return+ SatResult+ { sat = Left Impossible+ , dsat = Right mempty+ }+ Boolean True ->+ return+ SatResult+ { sat = Right mempty+ , dsat = Left Impossible+ }+ Key vk -> withLiteral guardKey satisfyKey vk+ where+ satisfyKey k+ | Just pk <- keyDescPubKey k+ , Just s <- lookupSignature pk sc =+ satVals (fromScript [pushSig s]) (SatScript 1 [OP_0])+ | otherwise =+ return+ SatResult+ { sat = Left $ MissingSignature [k]+ , dsat = return $ SatScript 1 [OP_0]+ }+ KeyH vk -> withLiteral guardKey satisfyKeyH vk+ where+ satisfyKeyH k+ | Just pk <- keyDescPubKey k+ , Just s <- lookupSignature pk sc =+ satVals+ (fromScript [pushSig s, pushKey pk])+ (fromScript [OP_0, pushKey pk])+ | Just pk <- keyDescPubKey k =+ return+ SatResult+ { sat = Left $ MissingSignature [k]+ , dsat = Right $ fromScript [OP_0, pushKey pk]+ }+ | otherwise = satErr $ AbstractKey k+ Sha256 h -> withLiteral guardBytes satisfyHash h+ Ripemd160 h -> withLiteral guardBytes satisfyHash h+ Hash256 h -> withLiteral guardBytes satisfyHash h+ Hash160 h -> withLiteral guardBytes satisfyHash h+ AndOr x y z -> satAndOr <$> satisfyInContext x <*> satisfyInContext y <*> satisfyInContext z+ where+ satAndOr sx sy sz =+ SatResult+ { sat = satConcat sat sy sat sx `satOr` satConcat sat sz dsat sx+ , dsat = satConcat dsat sz dsat sx+ }+ AndV x y -> satAndV <$> satisfyInContext x <*> satisfyInContext y+ where+ satAndV sx sy =+ SatResult+ { sat = satConcat sat sy sat sx+ , dsat = return mempty+ }+ AndB x y -> satAndB <$> satisfyInContext x <*> satisfyInContext y+ where+ satAndB sx sy =+ SatResult+ { sat = satConcat sat sy sat sx+ , dsat = satConcat dsat sy dsat sx+ }+ OrB x z -> satOrB <$> satisfyInContext x <*> satisfyInContext z+ where+ satOrB sx sz =+ SatResult+ { sat = satConcat dsat sz sat sx `satOr` satConcat sat sz dsat sx+ , dsat = satConcat dsat sz dsat sx+ }+ OrC x z -> satOrC <$> satisfyInContext x <*> satisfyInContext z+ where+ satOrC sx sz =+ SatResult+ { sat = sat sx `satOr` satConcat sat sz dsat sx+ , dsat = Left Impossible+ }+ OrD x z -> satOrD <$> satisfyInContext x <*> satisfyInContext z+ where+ satOrD sx sz =+ SatResult+ { sat = sat sx `satOr` satConcat sat sz dsat sx+ , dsat = satConcat dsat sz dsat sx+ }+ OrI x z -> satOrI <$> satisfyInContext x <*> satisfyInContext z+ where+ satOrI sx sz =+ SatResult+ { sat =+ let satA = (<> SatScript 1 [OP_1]) <$> sat sx+ satB = (<> SatScript 1 [OP_0]) <$> sat sz+ in satA `satOr` satB+ , dsat =+ let dsatA = (<> SatScript 1 [OP_1]) <$> dsat sx+ dsatB = (<> SatScript 1 [OP_0]) <$> dsat sz+ in dsatA `satOr` dsatB+ }+ Thresh vk x xs -> withLiteral guardNumber satisfyThresh vk+ where+ satisfyThresh k = do+ sxs <- traverse satisfyInContext (x : xs)+ return+ SatResult+ { sat = getSat $ satResults k sxs+ , dsat = getSat $ dsatResults k sxs+ }++ getSat = foldl' accumResult (Left Impossible)+ satResults k sxs = rights $ fmap mconcat . sequence <$> choose k sat dsat (reverse sxs)+ dsatResults k sxs = rights $ fmap mconcat . sequence <$> chooseComplement k sat dsat (reverse sxs)++ chooseComplement k f g zs = concatMap (\k' -> choose k' f g zs) $ filter (/= k) [0 .. length zs]++ accumResult z@(Right s0) s1+ | satWeight s1 < satWeight s0 = Right s1+ | otherwise = z+ accumResult Left{} s = Right s+ Multi vk vks -> withLiteral guardNumber stageSatisfyMulti vk+ where+ stageSatisfyMulti k = withKeys (satisfyMulti k) vks mempty++ satisfyMulti k ks+ | Just pks <- traverse keyDescPubKey ks+ , ss <- mapMaybe (`lookupSignature` sc) pks+ , Just result <- foldl' accumMS Nothing $ bestSigs k ss =+ satVals result (dsatScript k)+ | otherwise = return SatResult{sat = Left $ MissingSignature ks, dsat = return $ dsatScript k}++ bestSigs k ss = fromScript . (OP_0 :) . catMaybes <$> choose k (Just . pushSig) (const Nothing) ss++ accumMS Nothing s = Just s+ accumMS x@(Just s1) s2+ | satWeight s2 < satWeight s1 = Just s2+ | otherwise = x++ withKeys f (x : xs) ks = withLiteral guardKey (withKeys f xs . (: ks)) x+ withKeys f [] ks = f ks++ dsatScript k = SatScript (k + 1) $ replicate (k + 1) OP_0+ AnnA x -> satisfyInContext x+ AnnS x -> satisfyInContext x+ AnnC x -> satisfyInContext x+ AnnD x -> revise <$> satisfyInContext x+ where+ revise s =+ s+ { sat = (<> SatScript 1 [OP_1]) <$> sat s+ , dsat = return $ SatScript 1 [OP_0]+ }+ AnnV x -> revise <$> satisfyInContext x+ where+ revise s = s{dsat = Left Impossible}+ AnnJ x -> revise <$> satisfyInContext x+ where+ revise s = s{dsat = return $ SatScript 1 [OP_0]}+ AnnN x -> satisfyInContext x+ Number{} -> return SatResult{sat = return mempty, dsat = Left Impossible}+ Bytes{} -> return SatResult{sat = return mempty, dsat = Left Impossible}+ KeyDesc{} -> return SatResult{sat = return mempty, dsat = Left Impossible}+ Older va -> traverse onAge (utxoAge chainState) >>= maybe (satErr Impossible) return+ where+ onAge age = withLiteral guardNumber (return . satisfyOlder age) va+ satisfyOlder age reqAge+ | age >= reqAge = SatResult{sat = return mempty, dsat = Left Impossible}+ | otherwise = SatResult{sat = Left Impossible, dsat = return mempty}+ After vh -> traverse onHeight (blockHeight chainState) >>= maybe (satErr Impossible) return+ where+ onHeight h = withLiteral guardNumber (return . satisfyAfter h) vh+ satisfyAfter height reqHeight+ | height >= reqHeight = SatResult{sat = return mempty, dsat = Left Impossible}+ | otherwise = SatResult{sat = Left Impossible, dsat = return mempty}+ Var name -> requiredValue name satisfyInContext+ Let name x b -> local (Map.insert name x) $ satisfyInContext b+ where+ satisfyInContext = satisfy' chainState sc++ -- it is still possible to dissatisfy when we do not know the preimage since+ -- we can easily detect that some value is _not_ it+ satisfyHash h+ | Just p <- lookupPreimage h sc =+ satVals (fromScript [opPushData p]) (fromScript [opPushData $ otherValue p])+ | otherwise = satErr $ MissingPreimage h++pushSig :: Signature -> ScriptOp+pushSig (Signature s sh) = opPushData . encodeTxSig $ TxSignature s sh++pushKey :: PubKeyI -> ScriptOp+pushKey (PubKeyI k c) = opPushData $ exportPubKey c k++-- TODO fingerprinting implications+otherValue :: ByteString -> ByteString+otherValue bs+ | bs == zero32 = BS.pack $ replicate 32 0x1+ | otherwise = zero32++zero32 :: ByteString+zero32 = BS.pack $ replicate 32 0x0++withLiteral ::+ (Miniscript -> Either SatisfactionError a) ->+ (a -> Reader (Map Text Miniscript) SatResult) ->+ Value a ->+ Reader (Map Text Miniscript) SatResult+withLiteral g f = \case+ Lit n -> f n+ Variable n -> requiredValue n $ either satErr f . g++requiredValue ::+ Text ->+ (Miniscript -> Reader (Map Text Miniscript) SatResult) ->+ Reader (Map Text Miniscript) SatResult+requiredValue name f = asks (Map.lookup name) >>= maybe (satErr $ FreeVariable name) f++guardNumber :: Miniscript -> Either SatisfactionError Int+guardNumber (Number n) = return n+guardNumber e = Left $ TypeError "number" e++guardKey :: Miniscript -> Either SatisfactionError KeyDescriptor+guardKey (KeyDesc k) = return k+guardKey e = Left $ TypeError "key" e++guardBytes :: Miniscript -> Either SatisfactionError ByteString+guardBytes (Bytes b) = return b+guardBytes e = Left $ TypeError "bytes" e++satVals :: Monad m => SatScript -> SatScript -> m SatResult+satVals x y = return $ SatResult (Right x) (Right y)++satErr :: Monad m => SatisfactionError -> m SatResult+satErr = return . (SatResult <$> Left <*> Left)++satConcat :: (Applicative f, Monoid m) => (a -> f m) -> a -> (b -> f m) -> b -> f m+satConcat f x g y = (<>) <$> f x <*> g y++satOr :: Either e SatScript -> Either e SatScript -> Either e SatScript+satOr xA@(Right sA) xB@(Right sB)+ | satWeight sA <= satWeight sB = xA+ | otherwise = xB+satOr sA sB = sA <> sB++choose :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]+choose 0 _ onExclude xs = [onExclude <$> xs]+choose k onInclude _ xs+ | k == length xs = [onInclude <$> xs]+ | k > length xs = []+choose k onInclude onExclude (x : xs) =+ (handleX onInclude <$> choose (k -1) onInclude onExclude xs)+ <> (handleX onExclude <$> choose k onInclude onExclude xs)+ where+ handleX f zs = f x : zs+choose _ _ _ [] = []
+ src/Language/Bitcoin/Script/Descriptors.hs view
@@ -0,0 +1,28 @@+{- | A library for working with bitcoin script descriptors. Documentation taken+ from <https://github.com/bitcoin/bitcoin/blob/master/doc/descriptors.md>.+-}+module Language.Bitcoin.Script.Descriptors (+ ScriptDescriptor (..),+ KeyDescriptor (..),+ Origin (..),+ Key (..),+ KeyCollection (..),+ pubKey,+ secKey,+ keyDescPubKey,+ keyBytes,++ -- * Text representation+ descriptorToText,+ keyDescriptorToText,++ -- * Parsing+ parseDescriptor,+ descriptorParser,+ parseKeyDescriptor,+ keyDescriptorParser,+) where++import Language.Bitcoin.Script.Descriptors.Parser+import Language.Bitcoin.Script.Descriptors.Syntax+import Language.Bitcoin.Script.Descriptors.Text
+ src/Language/Bitcoin/Script/Descriptors/Parser.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Bitcoin.Script.Descriptors.Parser (+ parseDescriptor,+ descriptorParser,+ parseKeyDescriptor,+ keyDescriptorParser,+) where++import Control.Applicative (optional, (<|>))+import Data.Attoparsec.Text (Parser)+import qualified Data.Attoparsec.Text as A+import Data.Bool (bool)+import qualified Data.ByteString as BS+import Data.Maybe (isJust)+import Data.Text (Text, pack)+import Haskoin.Address (textToAddr)+import Haskoin.Constants (Network)+import Haskoin.Keys (+ DerivPath,+ DerivPathI (..),+ fromWif,+ importPubKey,+ wrapPubKey,+ xPubImport,+ )++import Language.Bitcoin.Script.Descriptors.Syntax+import Language.Bitcoin.Utils (+ alphanum,+ application,+ argList,+ brackets,+ comma,+ hex,+ maybeFail,+ )++parseDescriptor :: Network -> Text -> Either String ScriptDescriptor+parseDescriptor net = A.parseOnly $ descriptorParser net++descriptorParser :: Network -> Parser ScriptDescriptor+descriptorParser net =+ shP <|> wshP <|> pkP <|> pkhP <|> wpkhP <|> comboP <|> rawP <|> addrP+ <|> multiP+ <|> sortedMultiP+ where+ dp = descriptorParser net+ kp = keyDescriptorParser net++ shP = Sh <$> application "sh" dp+ wshP = Wsh <$> application "wsh" dp+ pkP = Pk <$> application "pk" kp+ pkhP = Pkh <$> application "pkh" kp+ wpkhP = Wpkh <$> application "wpkh" kp+ comboP = Combo <$> application "combo" kp+ rawP = Raw <$> application "raw" hex++ addrP =+ application "addr" (A.manyTill A.anyChar $ A.char ')')+ >>= maybeFail "descriptorParser: unable to parse address" Addr . textToAddr net . pack++ multiP = application "multi" $ Multi <$> A.decimal <*> comma keyList+ sortedMultiP = application "sortedmulti" $ SortedMulti <$> A.decimal <*> comma keyList++ keyList = argList kp++parseKeyDescriptor :: Network -> Text -> Either String KeyDescriptor+parseKeyDescriptor net = A.parseOnly $ keyDescriptorParser net++keyDescriptorParser :: Network -> Parser KeyDescriptor+keyDescriptorParser net = KeyDescriptor <$> originP <*> keyP+ where+ originP = optional . brackets $ Origin <$> A.hexadecimal <*> pathP++ keyP = pubP <|> wifP <|> XPub <$> xpubP <*> pathP <*> famP++ pubP = do+ bs <- hex+ maybeFail "Unable to parse pubkey" (toPubKey bs) $ importPubKey bs++ toPubKey bs = Pubkey . wrapPubKey (isCompressed bs)+ isCompressed bs = BS.length bs == 33++ wifP = A.many1' alphanum >>= maybeFail "Unable to parse WIF secret key" SecretKey . fromWif net . pack+ xpubP = A.many1' alphanum >>= maybeFail "Unable to parse xpub" id . xPubImport net . pack++ famP = (HardKeys <$ A.string "/*'") <|> (SoftKeys <$ A.string "/*") <|> pure Single++pathP :: Parser DerivPath+pathP = go Deriv+ where+ go d = maybe (return d) go =<< optional (componentP d)++ componentP d = do+ _ <- A.char '/'+ n <- A.decimal+ isHard <- isJust <$> optional (A.char '\'' <|> A.char 'h')+ return $ bool (d :/) (d :|) isHard n
+ src/Language/Bitcoin/Script/Descriptors/Syntax.hs view
@@ -0,0 +1,97 @@+module Language.Bitcoin.Script.Descriptors.Syntax (+ ScriptDescriptor (..),+ KeyDescriptor (..),+ Origin (..),+ Key (..),+ KeyCollection (..),+ pubKey,+ secKey,+ keyDescPubKey,+ keyBytes,+) where++import Data.ByteString (ByteString)+import Haskoin.Address (Address)+import Haskoin.Keys (+ DerivPath,+ Fingerprint,+ PubKeyI (..),+ SecKeyI,+ XPubKey,+ derivePubKeyI,+ exportPubKey,+ )++data ScriptDescriptor+ = -- | P2SH embed the argument.+ Sh ScriptDescriptor+ | -- | P2WSH embed the argument.+ Wsh ScriptDescriptor+ | -- | P2PK output for the given public key.+ Pk KeyDescriptor+ | -- | P2PKH output for the given public key (use 'Addr' if you only know the pubkey hash).+ Pkh KeyDescriptor+ | -- | P2WPKH output for the given compressed pubkey.+ Wpkh KeyDescriptor+ | -- | An alias for the collection of pk(KEY) and pkh(KEY). If the key is+ -- compressed, it also includes wpkh(KEY) and sh(wpkh(KEY)).+ Combo KeyDescriptor+ | -- | k-of-n multisig script.+ Multi Int [KeyDescriptor]+ | -- | k-of-n multisig script with keys sorted lexicographically in the resulting script.+ SortedMulti Int [KeyDescriptor]+ | -- | the script which ADDR expands to.+ Addr Address+ | -- | the script whose hex encoding is HEX.+ Raw ByteString+ deriving (Eq, Show)++data KeyDescriptor = KeyDescriptor+ { origin :: Maybe Origin+ , keyDef :: Key+ }+ deriving (Eq, Show)++data Origin = Origin+ { fingerprint :: Fingerprint+ , derivation :: DerivPath+ }+ deriving (Eq, Ord, Show)++data Key+ = -- | DER-hex encoded secp256k1 public key+ Pubkey PubKeyI+ | -- | (de)serialized as WIF+ SecretKey SecKeyI+ | XPub XPubKey DerivPath KeyCollection+ deriving (Eq, Show)++-- | Simple explicit public key with no origin information+pubKey :: PubKeyI -> KeyDescriptor+pubKey = KeyDescriptor Nothing . Pubkey++-- | Simple explicit secret key with no origin information+secKey :: SecKeyI -> KeyDescriptor+secKey = KeyDescriptor Nothing . SecretKey++-- | Represent whether the key corresponds to a collection (and how) or a single key.+data KeyCollection+ = Single+ | -- | immediate hardened children+ HardKeys+ | -- | immediate non-hardened children+ SoftKeys+ deriving (Eq, Ord, Show)++-- | Produce a key literal if possible+keyBytes :: KeyDescriptor -> Maybe ByteString+keyBytes = fmap toBytes . keyDescPubKey+ where+ toBytes (PubKeyI pk c) = exportPubKey c pk++-- | Produce a pubkey if possible+keyDescPubKey :: KeyDescriptor -> Maybe PubKeyI+keyDescPubKey (KeyDescriptor _ k) = case k of+ Pubkey pk -> Just pk+ SecretKey sk -> Just $ derivePubKeyI sk+ _ -> Nothing
+ src/Language/Bitcoin/Script/Descriptors/Text.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Convert descriptors to text+module Language.Bitcoin.Script.Descriptors.Text (+ descriptorToText,+ keyDescriptorToText,+) where++import Data.ByteString.Builder (+ toLazyByteString,+ word32BE,+ )+import Data.ByteString.Lazy (toStrict)+import Data.Maybe (fromMaybe)+import Data.Text (+ Text,+ intercalate,+ pack,+ )+import Haskoin.Address (addrToText)+import Haskoin.Constants (Network)+import Haskoin.Keys (+ PubKeyI (..),+ exportPubKey,+ pathToStr,+ toWif,+ xPubExport,+ )+import Haskoin.Util (encodeHex)++import Language.Bitcoin.Script.Descriptors.Syntax+import Language.Bitcoin.Utils (+ applicationText,+ showText,+ )++descriptorToText :: Network -> ScriptDescriptor -> Text+descriptorToText net = \case+ Sh x -> applicationText "sh" $ pd x+ Wsh x -> applicationText "wsh" $ pd x+ Pk k -> applicationText "pk" $ pk k+ Pkh k -> applicationText "pkh" $ pk k+ Wpkh k -> applicationText "wpkh" $ pk k+ Combo k -> applicationText "combo" $ pk k+ Addr a -> applicationText "addr" . fromMaybe addrErr $ addrToText net a+ Raw bs -> applicationText "raw" $ encodeHex bs+ Multi k ks ->+ applicationText "multi" . intercalate "," $ showText k : (pk <$> ks)+ SortedMulti k ks ->+ applicationText "sortedmulti" . intercalate "," $ showText k : (pk <$> ks)+ where+ pd = descriptorToText net+ pk = keyDescriptorToText net++ addrErr = error "Unable to parse address"++keyDescriptorToText :: Network -> KeyDescriptor -> Text+keyDescriptorToText net (KeyDescriptor o k) = maybe mempty originText o <> definitionText+ where+ originText (Origin fp path) = "[" <> fingerprintText fp <> pack (pathToStr path) <> "]"++ definitionText = case k of+ Pubkey (PubKeyI key c) -> encodeHex $ exportPubKey c key+ SecretKey key -> toWif net key+ XPub xpub path fam -> xPubExport net xpub <> (pack . pathToStr) path <> famText fam++ famText = \case+ Single -> ""+ HardKeys -> "/*'"+ SoftKeys -> "/*"++ fingerprintText = encodeHex . toStrict . toLazyByteString . word32BE
+ src/Language/Bitcoin/Script/Utils.hs view
@@ -0,0 +1,49 @@+module Language.Bitcoin.Script.Utils (+ pushNumber,+ toCScriptNum,+ fromCScriptNum,+) where++import Data.Bits (clearBit, setBit, testBit)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Word (Word8)+import Haskoin.Script (ScriptOp, opPushData)++-- | Decode a numeric stack value+fromCScriptNum :: ByteString -> Int+fromCScriptNum b+ | BS.null b = 0+ | msb == 0x80 = negate . fromIntegral $ leWord64 b'+ | testBit msb 7 = negate . fromIntegral . leWord64 $ BS.snoc b' (clearBit msb 7)+ | otherwise = fromIntegral $ leWord64 b+ where+ Just (b', msb) = BS.unsnoc b++-- | Encode a numeric stack value+toCScriptNum :: Int -> ByteString+toCScriptNum n+ | n == 0 = BS.empty+ | testBit msb 7 && n > 0 = BS.snoc b 0x00+ | testBit msb 7 && n < 0 = BS.snoc b 0x80+ | n < 0 = BS.snoc b' $ setBit msb 7+ | otherwise = b+ where+ (b', msb) = intLE n+ b = BS.snoc b' msb++pushNumber :: Int -> ScriptOp+pushNumber = opPushData . toCScriptNum++intLE :: Int -> (ByteString, Word8)+intLE = go mempty . abs+ where+ go b n+ | n < 0xff = (b, fromIntegral n)+ | otherwise = let (q, r) = n `quotRem` 256 in go (BS.snoc b $ fromIntegral r) q++leWord64 :: ByteString -> Int+leWord64 bs = sum $ zipWith mult (BS.unpack bs) orders+ where+ mult x y = fromIntegral x * y+ orders = (256 ^) <$> [0 :: Int ..]
+ src/Language/Bitcoin/Utils.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Various parsing and printing utilities+module Language.Bitcoin.Utils where++import Control.Applicative ((<|>))+import Control.Monad (void)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (Except, throwE)+import Control.Monad.Trans.Reader (ReaderT, asks)+import Data.Attoparsec.Text (Parser)+import qualified Data.Attoparsec.Text as A+import Data.ByteString (ByteString)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text, pack)+import Haskoin.Util (decodeHex)++parens :: Parser a -> Parser a+parens p = A.char '(' >> p <* A.char ')'++brackets :: Parser a -> Parser a+brackets p = A.char '[' >> p <* A.char ']'++application :: Text -> Parser a -> Parser a+application fname p = A.string fname >> parens (spacePadded p)++hex :: Parser ByteString+hex = A.many1' hexChar >>= maybeFail "Invalid hex" id . decodeHex . pack+ where+ hexChar = A.satisfy $ A.inClass chars+ chars = ['0' .. '9'] <> ['a' .. 'f'] <> ['A' .. 'F']++-- | Allow for a leading comma+comma :: Parser a -> Parser a+comma p = spacePadded (A.char ',') >> p++argList :: Parser a -> Parser [a]+argList p = spacePadded p `A.sepBy` A.char ','++alphanum :: Parser Char+alphanum = A.digit <|> A.letter++spacePadded :: Parser a -> Parser a+spacePadded p = spaces >> p <* spaces++spaces :: Parser ()+spaces = void $ A.many' A.space++showText :: Show a => a -> Text+showText = pack . show++applicationText :: Text -> Text -> Text+applicationText f x = f <> "(" <> x <> ")"++maybeFail :: String -> (a -> b) -> Maybe a -> Parser b+maybeFail msg f = maybe (fail msg) (return . f)++requiredContextValue :: (r -> Map Text c) -> e -> Text -> ReaderT r (Except e) c+requiredContextValue f e name = asks (Map.lookup name . f) >>= maybe (lift $ throwE e) return
+ test/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Test.Tasty (defaultMain, testGroup)++import Test.Descriptors (descriptorTests)+import Test.Miniscript (miniscriptTests)++main :: IO ()+main = defaultMain $ testGroup "bitcoin scripting" [descriptorTests, miniscriptTests]
+ test/Test/Descriptors.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE OverloadedStrings #-}++-- | We took these examples from <https://github.com/bitcoin/bitcoin/blob/master/doc/descriptors.md>+module Test.Descriptors (+ descriptorTests,+) where++import Data.Text (Text)+import Haskoin.Constants (btc)+import Haskoin.Keys (+ DerivPathI (..),+ PubKeyI (..),+ importPubKey,+ xPubImport,+ )+import Haskoin.Util (decodeHex)+import Test.Tasty (TestTree, testGroup)++import Language.Bitcoin.Script.Descriptors (+ Key (..),+ KeyCollection (..),+ KeyDescriptor (..),+ Origin (..),+ ScriptDescriptor (..),+ descriptorToText,+ parseDescriptor,+ )++import Test.Example (Example (..), testTextRep)++descriptorTests :: TestTree+descriptorTests =+ testGroup "descriptor tests" $+ testTextRep (parseDescriptor btc) (descriptorToText btc) <$> examples+ where+ examples =+ [ example1+ , example2+ , example3+ , example4+ , example5+ , example6+ , example7+ , example8+ , example9+ , example10+ , example11+ , example12+ , example13+ , example14+ , example15+ , example16+ ]++key :: PubKeyI -> KeyDescriptor+key = KeyDescriptor Nothing . Pubkey++hexPubkey :: Text -> PubKeyI+hexPubkey h = PubKeyI k True+ where+ Just k = importPubKey =<< decodeHex h++example1 :: Example ScriptDescriptor+example1 =+ Example+ { name = "pk"+ , text = "pk(0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798)"+ , script = Pk $ key k+ }+ where+ k = hexPubkey "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"++example2 :: Example ScriptDescriptor+example2 =+ Example+ { name = "pkh"+ , text = "pkh(02c6047f9441ed7d6d3045406e95c07cd85c778e4b8cef3ca7abac09b95c709ee5)"+ , script = Pkh $ key k+ }+ where+ k = hexPubkey "02c6047f9441ed7d6d3045406e95c07cd85c778e4b8cef3ca7abac09b95c709ee5"++example3 :: Example ScriptDescriptor+example3 =+ Example+ { name = "wpkh"+ , text = "wpkh(02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9)"+ , script = Wpkh $ key k+ }+ where+ k = hexPubkey "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9"++example4 :: Example ScriptDescriptor+example4 =+ Example+ { name = "p2sh-p2wpkh"+ , text = "sh(wpkh(03fff97bd5755eeea420453a14355235d382f6472f8568a18b2f057a1460297556))"+ , script = Sh . Wpkh $ key k+ }+ where+ k = hexPubkey "03fff97bd5755eeea420453a14355235d382f6472f8568a18b2f057a1460297556"++example5 :: Example ScriptDescriptor+example5 =+ Example+ { name = "combo"+ , text = "combo(0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798)"+ , script = Combo $ key k+ }+ where+ k = hexPubkey "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"++example6 :: Example ScriptDescriptor+example6 =+ Example+ { name = "p2sh-p2wsh-p2pkh"+ , text = "sh(wsh(pkh(02e493dbf1c10d80f3581e4904930b1404cc6c13900ee0758474fa94abe8c4cd13)))"+ , script = Sh . Wsh . Pkh $ key k+ }+ where+ k = hexPubkey "02e493dbf1c10d80f3581e4904930b1404cc6c13900ee0758474fa94abe8c4cd13"++example7 :: Example ScriptDescriptor+example7 =+ Example+ { name = "multi"+ , text =+ "multi(1,022f8bde4d1a07209355b4a7250a5c5128e88b84bddc619ab7cba8d569b240efe4,\+ \025cbdf0646e5db4eaa398f365f2ea7a0e3d419b7e0330e39ce92bddedcac4f9bc)"+ , script = Multi 1 [key k1, key k2]+ }+ where+ k1 = hexPubkey "022f8bde4d1a07209355b4a7250a5c5128e88b84bddc619ab7cba8d569b240efe4"+ k2 = hexPubkey "025cbdf0646e5db4eaa398f365f2ea7a0e3d419b7e0330e39ce92bddedcac4f9bc"++example8 :: Example ScriptDescriptor+example8 =+ Example+ { name = "p2sh-multisig"+ , text =+ "sh(multi(2,022f01e5e15cca351daff3843fb70f3c2f0a1bdd05e5af888a67784ef3e10a2a01,\+ \03acd484e2f0c7f65309ad178a9f559abde09796974c57e714c35f110dfc27ccbe))"+ , script = Sh $ Multi 2 [key k1, key k2]+ }+ where+ k1 = hexPubkey "022f01e5e15cca351daff3843fb70f3c2f0a1bdd05e5af888a67784ef3e10a2a01"+ k2 = hexPubkey "03acd484e2f0c7f65309ad178a9f559abde09796974c57e714c35f110dfc27ccbe"++example9 :: Example ScriptDescriptor+example9 =+ Example+ { name = "p2sh-multisig lexicographic"+ , text =+ "sh(sortedmulti(2,03acd484e2f0c7f65309ad178a9f559abde09796974c57e714c35f110dfc27ccbe,\+ \022f01e5e15cca351daff3843fb70f3c2f0a1bdd05e5af888a67784ef3e10a2a01))"+ , script = Sh $ SortedMulti 2 [key k1, key k2]+ }+ where+ k1 = hexPubkey "03acd484e2f0c7f65309ad178a9f559abde09796974c57e714c35f110dfc27ccbe"+ k2 = hexPubkey "022f01e5e15cca351daff3843fb70f3c2f0a1bdd05e5af888a67784ef3e10a2a01"++example10 :: Example ScriptDescriptor+example10 =+ Example+ { name = "p2wsh-multi"+ , text =+ "wsh(multi(2,03a0434d9e47f3c86235477c7b1ae6ae5d3442d49b1943c2b752a68e2a47e247c7,\+ \03774ae7f858a9411e5ef4246b70c65aac5649980be5c17891bbec17895da008cb,\+ \03d01115d548e7561b15c38f004d734633687cf4419620095bc5b0f47070afe85a))"+ , script = Wsh $ Multi 2 [key k1, key k2, key k3]+ }+ where+ k1 = hexPubkey "03a0434d9e47f3c86235477c7b1ae6ae5d3442d49b1943c2b752a68e2a47e247c7"+ k2 = hexPubkey "03774ae7f858a9411e5ef4246b70c65aac5649980be5c17891bbec17895da008cb"+ k3 = hexPubkey "03d01115d548e7561b15c38f004d734633687cf4419620095bc5b0f47070afe85a"++example11 :: Example ScriptDescriptor+example11 =+ Example+ { name = "p2sh-p2wsh-mulisig"+ , text =+ "sh(wsh(multi(1,03f28773c2d975288bc7d1d205c3748651b075fbc6610e58cddeeddf8f19405aa8,\+ \03499fdf9e895e719cfd64e67f07d38e3226aa7b63678949e6e49b241a60e823e4,\+ \02d7924d4f7d43ea965a465ae3095ff41131e5946f3c85f79e44adbcf8e27e080e)))"+ , script = Sh . Wsh $ Multi 1 [key k1, key k2, key k3]+ }+ where+ k1 = hexPubkey "03f28773c2d975288bc7d1d205c3748651b075fbc6610e58cddeeddf8f19405aa8"+ k2 = hexPubkey "03499fdf9e895e719cfd64e67f07d38e3226aa7b63678949e6e49b241a60e823e4"+ k3 = hexPubkey "02d7924d4f7d43ea965a465ae3095ff41131e5946f3c85f79e44adbcf8e27e080e"++example12 :: Example ScriptDescriptor+example12 =+ Example+ { name = "xpub"+ , text = "pk(xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8)"+ , script = Pk $ KeyDescriptor Nothing (XPub xpub Deriv Single)+ }+ where+ Just xpub = xPubImport btc "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8"++example13 :: Example ScriptDescriptor+example13 =+ Example+ { name = "p2pkh-xpub with derivation"+ , text = "pkh(xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw/1'/2)"+ , script = Pkh $ KeyDescriptor Nothing (XPub xpub (Deriv :| 1 :/ 2) Single)+ }+ where+ Just xpub = xPubImport btc "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw"++example14 :: Example ScriptDescriptor+example14 =+ Example+ { name = "pkh-xpub with origin and collection spec"+ , text = "pkh([d34db33f/44'/0'/0']xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL/1/*)"+ , script = Pkh $ KeyDescriptor (Just (Origin fp (Deriv :| 44 :| 0 :| 0))) (XPub xpub (Deriv :/ 1) SoftKeys)+ }+ where+ Just xpub = xPubImport btc "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL"+ fp = 0xd34db33f++example15 :: Example ScriptDescriptor+example15 =+ Example+ { name = "wsh-multisig xpub collections"+ , text =+ "wsh(multi(1,xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB/1/0/*,\+ \xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH/0/0/*))"+ , script =+ Wsh $+ Multi+ 1+ [ KeyDescriptor Nothing (XPub xpub1 (Deriv :/ 1 :/ 0) SoftKeys)+ , KeyDescriptor Nothing (XPub xpub2 (Deriv :/ 0 :/ 0) SoftKeys)+ ]+ }+ where+ Just xpub1 = xPubImport btc "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB"+ Just xpub2 = xPubImport btc "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH"++example16 :: Example ScriptDescriptor+example16 =+ Example+ { name = "wsh-multi sorted"+ , text =+ "wsh(sortedmulti(1,xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB/1/0/*,\+ \xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH/0/0/*))"+ , script =+ Wsh $+ SortedMulti+ 1+ [ KeyDescriptor Nothing (XPub xpub1 (Deriv :/ 1 :/ 0) SoftKeys)+ , KeyDescriptor Nothing (XPub xpub2 (Deriv :/ 0 :/ 0) SoftKeys)+ ]+ }+ where+ Just xpub1 = xPubImport btc "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB"+ Just xpub2 = xPubImport btc "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH"
+ test/Test/Example.hs view
@@ -0,0 +1,34 @@+module Test.Example (+ Example (..),+ testTextRep,+ testExampleProperty,+) where++import Data.Text (Text)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertFailure, testCase, (@=?))+import Test.Tasty.QuickCheck (Property, testProperty)++data Example a = Example+ { name :: String+ , text :: Text+ , script :: a+ }++testTextRep ::+ (Eq a, Show a) =>+ (Text -> Either String a) ->+ (a -> Text) ->+ Example a ->+ TestTree+testTextRep parse encode e =+ testCase (name e)+ . either assertFailure parseSuccess+ $ parse (text e)+ where+ parseSuccess d = do+ d @=? script e+ encode d @=? text e++testExampleProperty :: Example a -> Property -> TestTree+testExampleProperty e = testProperty (name e)
+ test/Test/Miniscript.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+ Module: Test.Miniscript++ Examples taken from <http://bitcoin.sipa.be/miniscript/>+-}+module Test.Miniscript (+ miniscriptTests,+) where++import Haskoin.Constants (btc)+import Test.Tasty (TestTree, testGroup)++import Language.Bitcoin.Miniscript (miniscriptToText, parseMiniscript)+import Test.Example (testTextRep)+import Test.Miniscript.Compiler (compilerTests)+import Test.Miniscript.Examples+import Test.Miniscript.Types (typeCheckerTests)+import Test.Miniscript.Witness (witnessTests)++miniscriptTests :: TestTree+miniscriptTests =+ testGroup+ "miniscript"+ [ parsePrintTests+ , typeCheckerTests+ , compilerTests+ , witnessTests+ ]++parsePrintTests :: TestTree+parsePrintTests =+ testGroup "parsing-printing" $+ testTextRep (parseMiniscript btc) (miniscriptToText btc) <$> examples+ where+ examples =+ [ example1+ , example2+ , example3+ , example4+ , example5+ , example6+ , example7+ , example8+ , example9+ , example10+ ]
+ test/Test/Miniscript/Compiler.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++module Test.Miniscript.Compiler (+ compilerTests,+) where++import Data.ByteString (ByteString)+import Data.Functor (void)+import Data.Serialize (encode)+import Data.Text (Text)+import Haskoin.Crypto (ripemd160)+import Haskoin.Script (+ Script (..),+ ScriptOp (..),+ opPushData,+ )+import Haskoin.Util.Arbitrary.Keys (arbitraryKeyPair)+import Haskoin.Util.Arbitrary.Util (arbitraryBSn)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (+ Gen,+ Property,+ Testable,+ forAll,+ property,+ (===),+ )++import Language.Bitcoin.Miniscript (+ Miniscript (..),+ compile,+ let_,+ )+import Language.Bitcoin.Script.Descriptors (+ KeyDescriptor,+ keyBytes,+ pubKey,+ )+import Language.Bitcoin.Script.Utils (pushNumber)+import Test.Example (+ Example (..),+ testExampleProperty,+ )+import qualified Test.Miniscript.Examples as E+import Test.Utils (forAllLabeled, pr12, pr3)++compilerTests :: TestTree+compilerTests = testGroup "compiler" examples+ where+ examples =+ [ example1+ , example2+ , example3+ , example4+ , example5+ , example6+ , example7+ , example8+ , example9+ , example10+ ]++arbitraryKey :: Gen KeyDescriptor+arbitraryKey = pubKey . snd <$> arbitraryKeyPair++keyB :: Text -> KeyDescriptor -> (Text, Miniscript, ByteString)+keyB n k = (n, KeyDesc k, bs)+ where+ Just bs = keyBytes k++pushHash :: ByteString -> ScriptOp+pushHash = opPushData . encode . ripemd160++forKeys :: Testable p => [Text] -> ([(Text, Miniscript, ByteString)] -> p) -> Property+forKeys = forAllLabeled arbitraryKey keyB++arbitraryBytes32 :: Gen ByteString+arbitraryBytes32 = arbitraryBSn 32++scriptCompiles :: Example Miniscript -> [(Text, Miniscript)] -> Property+scriptCompiles e bs = void (compile . let_ bs $ script e) === Right ()++scriptCompilesTo :: Example Miniscript -> [(Text, Miniscript)] -> Script -> Property+scriptCompilesTo e bs s = compile (let_ bs $ script e) === Right s++example1 :: TestTree+example1 = testExampleProperty E.example1 $+ forAll arbitraryKey $ \k ->+ let Just bs = keyBytes k+ in scriptCompilesTo E.example1 [("key_1", KeyDesc k)] $ Script [opPushData bs, OP_CHECKSIG]++example2 :: TestTree+example2 = testExampleProperty E.example2 . forKeys ["key_1", "key_2"] $ \ks ->+ scriptCompilesTo E.example2 (pr12 <$> ks) $ result (pr3 <$> ks)+ where+ result [k1, k2] = Script [opPushData k1, OP_CHECKSIG, OP_SWAP, opPushData k2, OP_CHECKSIG, OP_BOOLOR]++example3 :: TestTree+example3 = testExampleProperty E.example3 . forKeys ["key_likely", "key_unlikely"] $ \ks ->+ scriptCompilesTo E.example3 (pr12 <$> ks) $ result (pr3 <$> ks)+ where+ result [k1, k2] =+ Script+ [ opPushData k1+ , OP_CHECKSIG+ , OP_IFDUP+ , OP_NOTIF+ , OP_DUP+ , OP_HASH160+ , pushHash k2+ , OP_EQUALVERIFY+ , OP_CHECKSIG+ , OP_ENDIF+ ]++example4 :: TestTree+example4 = testExampleProperty E.example4 . forKeys ["key_user", "key_service"] $ \ks ->+ scriptCompilesTo E.example4 (pr12 <$> ks) $ result (pr3 <$> ks)+ where+ result [k1, k2] =+ Script+ [ opPushData k1+ , OP_CHECKSIGVERIFY+ , opPushData k2+ , OP_CHECKSIG+ , OP_IFDUP+ , OP_NOTIF+ , pushNumber 12960+ , OP_CHECKSEQUENCEVERIFY+ , OP_ENDIF+ ]++example5 :: TestTree+example5 = testExampleProperty E.example5 . forKeys ["key_1", "key_2", "key_3"] $ \ks ->+ scriptCompilesTo E.example5 (pr12 <$> ks) $ result (pr3 <$> ks)+ where+ result [k1, k2, k3] =+ Script+ [ opPushData k1+ , OP_CHECKSIG+ , OP_SWAP+ , opPushData k2+ , OP_CHECKSIG+ , OP_ADD+ , OP_SWAP+ , opPushData k3+ , OP_CHECKSIG+ , OP_ADD+ , OP_SWAP+ , OP_DUP+ , OP_IF+ , pushNumber 12960+ , OP_CHECKSEQUENCEVERIFY+ , OP_VERIFY+ , OP_ENDIF+ , OP_ADD+ , pushNumber 3+ , OP_EQUAL+ ]++example6 :: TestTree+example6 = testExampleProperty E.example6 . forKeys ["key_local", "key_revocation"] $ \ks ->+ scriptCompilesTo E.example6 (pr12 <$> ks) $ result (pr3 <$> ks)+ where+ result [k1, k2] =+ Script+ [ opPushData k1+ , OP_CHECKSIG+ , OP_NOTIF+ , opPushData k2+ , OP_CHECKSIG+ , OP_ELSE+ , pushNumber 1008+ , OP_CHECKSEQUENCEVERIFY+ , OP_ENDIF+ ]++example7 :: TestTree+example7 = testExampleProperty E.example7 . forKeys ["key_local", "key_revocation", "key_remote"] $ \ks ->+ forAll arbitraryBytes32 $ \h ->+ let bindings = ("H", Bytes h) : (pr12 <$> ks)+ values = h : (pr3 <$> ks)+ in scriptCompilesTo E.example7 bindings $ result values+ where+ result [h, k1, k2, k3] =+ Script+ [ opPushData k2+ , OP_CHECKSIG+ , OP_NOTIF+ , opPushData k3+ , OP_CHECKSIGVERIFY+ , opPushData k1+ , OP_CHECKSIG+ , OP_NOTIF+ , OP_SIZE+ , pushNumber 32+ , OP_EQUALVERIFY+ , OP_HASH160+ , opPushData h+ , OP_EQUALVERIFY+ , OP_ENDIF+ , OP_ENDIF+ , OP_1+ ]++example8 :: TestTree+example8 = testExampleProperty E.example8 . forKeys ["key_revocation", "key_remote", "key_local"] $ \ks ->+ forAll arbitraryBytes32 $ \h ->+ let bindings = ("H", Bytes h) : (pr12 <$> ks)+ values = h : (pr3 <$> ks)+ in scriptCompilesTo E.example8 bindings $ result values+ where+ result [h, k1, k2, k3] =+ Script+ [ opPushData k2+ , OP_CHECKSIG+ , OP_NOTIF+ , opPushData k1+ , OP_CHECKSIG+ , OP_ELSE+ , OP_IF+ , OP_DUP+ , OP_HASH160+ , pushHash k3+ , OP_EQUALVERIFY+ , OP_CHECKSIGVERIFY+ , OP_SIZE+ , pushNumber 32+ , OP_EQUALVERIFY+ , OP_HASH160+ , opPushData h+ , OP_EQUAL+ , OP_ELSE+ , pushNumber 1008+ , OP_CHECKSEQUENCEVERIFY+ , OP_ENDIF+ , OP_ENDIF+ ]++example9 :: TestTree+example9 = testExampleProperty E.example9 . property $ scriptCompiles E.example9 mempty++example10 :: TestTree+example10 = testExampleProperty E.example10 $+ forKeys ["A", "B", "C", "D", "E"] $ \ks ->+ forKeys ["F", "G", "H"] $ \khs ->+ scriptCompilesTo E.example10 (fmap pr12 $ ks <> khs) $ result (fmap pr3 $ ks <> khs)+ where+ result [kA, kB, kC, kD, kE, kF, kG, kH] =+ Script+ [ pushNumber 4+ , opPushData kA+ , opPushData kB+ , opPushData kC+ , opPushData kD+ , opPushData kE+ , pushNumber 5+ , OP_CHECKMULTISIG+ , OP_IFDUP+ , OP_NOTIF+ , OP_DUP+ , OP_HASH160+ , pushHash kF+ , OP_EQUALVERIFY+ , OP_CHECKSIG+ , OP_TOALTSTACK+ , OP_DUP+ , OP_HASH160+ , pushHash kG+ , OP_EQUALVERIFY+ , OP_CHECKSIG+ , OP_FROMALTSTACK+ , OP_ADD+ , OP_TOALTSTACK+ , OP_DUP+ , OP_HASH160+ , pushHash kH+ , OP_EQUALVERIFY+ , OP_CHECKSIG+ , OP_FROMALTSTACK+ , OP_ADD+ , pushNumber 2+ , OP_EQUALVERIFY+ , pushNumber 13149+ , OP_CHECKSEQUENCEVERIFY+ , OP_ENDIF+ ]
+ test/Test/Miniscript/Examples.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Miniscript.Examples where++import Data.Text (Text)+import Language.Bitcoin.Miniscript (+ Annotation (..),+ Miniscript (..),+ literal,+ older,+ thresh,+ var,+ (.:),+ )+import Test.Example (Example (..))++keyVar :: Text -> Miniscript+keyVar = AnnC . Key . var++keyHVar :: Text -> Miniscript+keyHVar = AnnC . KeyH . var++example1 :: Example Miniscript+example1 =+ Example+ { name = "A single key"+ , text = "pk(key_1)"+ , script = keyVar "key_1"+ }++example2 :: Example Miniscript+example2 =+ Example+ { name = "One of two keys (equally likely)"+ , text = "or_b(pk(key_1),s:pk(key_2))"+ , script = keyVar "key_1" `OrB` (S .: keyVar "key_2")+ }++example3 :: Example Miniscript+example3 =+ Example+ { name = "One of two keys (one likely, one unlikely)"+ , text = "or_d(pk(key_likely),pkh(key_unlikely))"+ , script = keyVar "key_likely" `OrD` keyHVar "key_unlikely"+ }++example4 :: Example Miniscript+example4 =+ Example+ { name = "A user and a 2FA service need to sign off, but after 90 days the user alone is enough"+ , text = "and_v(v:pk(key_user),or_d(pk(key_service),older(12960)))"+ , script = AndV (V .: keyVar "key_user") (keyVar "key_service" `OrD` older 12960)+ }++example5 :: Example Miniscript+example5 =+ Example+ { name = "A 3-of-3 that turns into a 2-of-3 after 90 days"+ , text = "thresh(3,pk(key_1),s:pk(key_2),s:pk(key_3),sdv:older(12960))"+ , script =+ thresh+ 3+ (keyVar "key_1")+ [ S .: keyVar "key_2"+ , S .: keyVar "key_3"+ , [S, D, V] .: older 12960+ ]+ }++example6 :: Example Miniscript+example6 =+ Example+ { name = "The BOLT #3 to_local policy"+ , text = "andor(pk(key_local),older(1008),pk(key_revocation))"+ , script = AndOr (keyVar "key_local") (older 1008) (keyVar "key_revocation")+ }++example7 :: Example Miniscript+example7 =+ Example+ { name = "The BOLT #3 offered HTLC policy"+ , text = "t:or_c(pk(key_revocation),and_v(v:pk(key_remote),or_c(pk(key_local),v:hash160(H))))"+ , script =+ T+ .: ( keyVar "key_revocation"+ `OrC` AndV+ (V .: keyVar "key_remote")+ (keyVar "key_local" `OrC` (V .: Hash160 (var "H")))+ )+ }++example8 :: Example Miniscript+example8 =+ Example+ { name = "The BOLT #3 received HTLC policy"+ , text = "andor(pk(key_remote),or_i(and_v(v:pkh(key_local),hash160(H)),older(1008)),pk(key_revocation))"+ , script =+ AndOr+ (keyVar "key_remote")+ (AndV (V .: keyHVar "key_local") (Hash160 $ var "H") `OrI` older 1008)+ (keyVar "key_revocation")+ }++example9 :: Example Miniscript+example9 =+ Example+ { name = "Let binding"+ , text = "let timeout = 1008 in older(timeout)"+ , script = Let "timeout" (Number 1008) $ Older (var "timeout")+ }++-- ht @shesek+example10 :: Example Miniscript+example10 =+ Example+ { name = "Advanced 2FA"+ , text = "or_d(multi(4,A,B,C,D,E),and_v(v:thresh(2,pkh(F),a:pkh(G),a:pkh(H)),older(13149)))"+ , script = Multi (literal 4) [kA, kB, kC, kD, kE] `OrD` AndV (V .: thresh 2 kF [A .: kG, A .: kH]) (older 13149)+ }+ where+ kA = var "A"+ kB = var "B"+ kC = var "C"+ kD = var "D"+ kE = var "E"++ kF = keyHVar "F"+ kG = keyHVar "G"+ kH = keyHVar "H"
+ test/Test/Miniscript/Types.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Miniscript.Types (+ typeCheckerTests,+) where++import Haskoin.Util.Arbitrary.Keys (arbitraryKeyPair)+import Haskoin.Util.Arbitrary.Util (arbitraryBSn)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (+ Gen,+ forAll,+ testProperty,+ (===),+ )++import Language.Bitcoin.Miniscript (+ BaseType (..),+ Miniscript (..),+ MiniscriptType (..),+ let_,+ typeCheckMiniscript,+ )+import Language.Bitcoin.Script.Descriptors (KeyDescriptor, pubKey)+import Test.Example (script)+import Test.Miniscript.Examples (+ example6,+ example7,+ example8,+ )++typeCheckerTests :: TestTree+typeCheckerTests = testGroup "type checker" [localPolicy, offeredPolicy, receivedPolicy]++arbitraryKey :: Gen KeyDescriptor+arbitraryKey = pubKey . snd <$> arbitraryKeyPair++localPolicy :: TestTree+localPolicy = testProperty "bolt3 local policy" $+ forAll arbitraryKey $ \local ->+ forAll arbitraryKey $ \rev ->+ (baseType <$> typeCheckMiniscript mempty (bolt3LocalPolicy local rev)) === Right TypeB+ where+ bolt3LocalPolicy loc rev =+ let_+ [ ("key_local", KeyDesc loc)+ , ("key_revocation", KeyDesc rev)+ ]+ $ script example6++offeredPolicy :: TestTree+offeredPolicy = testProperty "bolt 3 offered policy" $+ forAll arbitraryKey $ \remote ->+ forAll arbitraryKey $ \local ->+ forAll arbitraryKey $ \revokation ->+ forAll (arbitraryBSn 32) $ \h ->+ (baseType <$> typeCheckMiniscript mempty (bolt3OfferedHTLCPolicy remote local revokation h)) === Right TypeB+ where+ bolt3OfferedHTLCPolicy rmt loc rev h =+ let_+ [ ("key_remote", KeyDesc rmt)+ , ("key_local", KeyDesc loc)+ , ("key_revocation", KeyDesc rev)+ , ("H", Bytes h)+ ]+ $ script example7++receivedPolicy :: TestTree+receivedPolicy = testProperty "bolt 3 received policy" $+ forAll arbitraryKey $ \remote ->+ forAll arbitraryKey $ \local ->+ forAll arbitraryKey $ \revokation ->+ forAll (arbitraryBSn 32) $ \h ->+ (baseType <$> typeCheckMiniscript mempty (bolt3ReceivedHTLCPolicy remote local revokation h)) === Right TypeB+ where+ bolt3ReceivedHTLCPolicy rmt loc rev h =+ let_+ [ ("key_remote", KeyDesc rmt)+ , ("key_local", KeyDesc loc)+ , ("key_revocation", KeyDesc rev)+ , ("H", Bytes h)+ ]+ $ script example8
+ test/Test/Miniscript/Witness.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++module Test.Miniscript.Witness (+ witnessTests,+) where++import Data.ByteString (ByteString)+import Data.Serialize (encode)+import Data.Text (Text)+import Haskoin.Crypto (+ ripemd160,+ sha256,+ signHash,+ )+import Haskoin.Keys (PubKeyI, secKeyData)+import Haskoin.Script (+ Script (..),+ ScriptOp (..),+ TxSignature (..),+ encodeTxSig,+ opPushData,+ sigHashAll,+ )+import Haskoin.Util.Arbitrary.Keys (arbitraryKeyPair)+import Haskoin.Util.Arbitrary.Util (arbitraryBSn)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (+ Gen,+ Property,+ Testable,+ forAll,+ (===),+ )++import Language.Bitcoin.Miniscript (Miniscript (..), let_)+import Language.Bitcoin.Miniscript.Witness (+ ChainState (..),+ SatisfactionError (..),+ Signature (..),+ emptyChainState,+ preimage,+ satisfactionContext,+ satisfy,+ signature,+ )+import Language.Bitcoin.Script.Descriptors (pubKey)+import Test.Example (+ Example (..),+ testExampleProperty,+ )+import qualified Test.Miniscript.Examples as E+import Test.Utils (forAllLabeled, pr23)++witnessTests :: TestTree+witnessTests = testGroup "witness" examples+ where+ examples =+ [ example1+ , example2+ , example3+ , example4+ , example5+ , example6+ , example7+ , example8+ , example9+ , example10+ ]++pushKey :: PubKeyI -> ScriptOp+pushKey = opPushData . encode++pushSig :: Signature -> ScriptOp+pushSig (Signature s sh) = opPushData . encodeTxSig $ TxSignature s sh++forKeys :: Testable p => [Text] -> Miniscript -> ([(PubKeyI, Signature)] -> Miniscript -> p) -> Property+forKeys ls scr k = forAllLabeled arbKeySig mkRow ls mkProp+ where+ mkRow label (pk, s) = (label, pk, s)+ mkProp xs = k (pr23 <$> xs) $ let_ (binding <$> xs) scr+ binding (l, pk, _) = (l, KeyDesc $ pubKey pk)++arbKeySig :: Gen (PubKeyI, Signature)+arbKeySig = repack <$> arbitraryKeyPair+ where+ repack (sk, pk) = (pk, mkSig $ secKeyData sk)++ mkSig s = Signature (signHash s $ sha256 msg) sigHashAll++ msg :: ByteString+ msg = "arbKeySig"++testExample ::+ Testable p =>+ Example Miniscript ->+ [Text] ->+ ([(PubKeyI, Signature)] -> Miniscript -> p) ->+ TestTree+testExample e ls = testExampleProperty e . forKeys ls (script e)++example1 :: TestTree+example1 = testExample E.example1 ["key_1"] test+ where+ test [(k, s)] scr = satisfy emptyChainState (signature k s) scr === Right (Script [pushSig s])++example2 :: TestTree+example2 = testExample E.example2 ["key_1", "key_2"] test+ where+ test xs scr = satisfy emptyChainState (context xs) scr === Right (expected xs)++ expected ((_, s) : _) = Script [OP_0, pushSig s]+ context (x : _) = uncurry signature x++example3 :: TestTree+example3 = testExample E.example3 ["key_likely", "key_unlikely"] test+ where+ test xs scr = satisfy emptyChainState (context xs) scr === Right (expected xs)++ expected (_ : (k, s) : _) = Script [pushSig s, pushKey k, OP_0]+ context (_ : x : _) = uncurry signature x++example4 :: TestTree+example4 = testExample E.example4 ["key_user", "key_service"] test+ where+ test xs scr = satisfy chainState (context xs) scr === Right (expected xs)++ expected ((_, s) : _) = Script [OP_0, pushSig s]+ context (x : _) = uncurry signature x++ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 20000}++example5 :: TestTree+example5 = testExample E.example5 ["key_1", "key_2", "key_3"] test+ where+ test xs scr = result xs scr === Right (expected xs)++ expected [(_, s1), _, (_, s3)] = Script [OP_1, pushSig s3, OP_0, pushSig s1]+ result [x1, _, x3] scr = satisfy chainState (context x1 x3) scr+ context (k1, s1) (k3, s3) = signature k1 s1 <> signature k3 s3++ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 13000}++example6 :: TestTree+example6 = testExample E.example6 ["key_local", "key_revocation"] test+ where+ test xs scr = result xs scr === Right (expected xs)++ expected [_, (_, s2)] = Script [pushSig s2, OP_0]+ result xs scr = satisfy chainState (context xs) scr+ context = foldMap (uncurry signature)++ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 100}++hashBinding :: ByteString -> Miniscript -> Miniscript+hashBinding bs = let_ [("H", Bytes . encode $ ripemd160 bs)]++example7 :: TestTree+example7 = testExample E.example7 ["key_local", "key_remote", "key_revocation"] test+ where+ test xs scr = forAll (arbitraryBSn 32) $ \bs ->+ satisfy chainState (context xs bs) (hashBinding bs scr) === Right (expected xs bs)++ expected [_, (_, s), _] bs = Script [opPushData bs, OP_0, pushSig s, OP_0]+ context [_, x, _] bs = uncurry signature x <> preimage (encode $ ripemd160 bs) bs++ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 2000}++example8 :: TestTree+example8 = testExample E.example8 ["key_local", "key_remote", "key_revocation"] test+ where+ test xs scr = forAll (arbitraryBSn 32) $ \bs ->+ satisfy chainState (context xs bs) (hashBinding bs scr) === Right (expected xs bs)++ expected [(kl, sl), (_, sr), _] bs = Script [opPushData bs, pushSig sl, pushKey kl, OP_1, pushSig sr]+ context [l, r, _] bs = satisfactionContext [(encode $ ripemd160 bs, bs)] [l, r]++ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 6}++example9 :: TestTree+example9 = testExample E.example9 [] test+ where+ test _ scr = satisfy chainState mempty scr === Left Impossible+ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 100}++example10 :: TestTree+example10 = testExample E.example10 ["A", "B", "C", "D", "E", "F", "G", "H"] test+ where+ test xs scr = satisfy chainState (context xs) scr === Right (expected xs)++ expected xs = Script $ OP_0 : drop 1 (foldMap pushPkhSig (reverse $ drop 5 xs)) <> replicate 5 OP_0+ context xs = foldMap (uncurry signature) . take 2 $ drop 5 xs++ chainState = ChainState{blockHeight = Nothing, utxoAge = Just 20000}++ pushPkhSig (k, s) = [pushSig s, pushKey k]
+ test/Test/Utils.hs view
@@ -0,0 +1,34 @@+module Test.Utils (+ forAllLabeled,+ pr12,+ pr23,+ pr3,+) where++import Data.Text (Text)+import Test.Tasty.QuickCheck (+ Gen,+ Property,+ Testable,+ forAll,+ property,+ )++pr12 :: (a, b, c) -> (a, b)+pr12 (x, y, _) = (x, y)++pr23 :: (a, b, c) -> (b, c)+pr23 (_, x, y) = (x, y)++pr3 :: (a, b, c) -> c+pr3 (_, _, x) = x++forAllLabeled ::+ (Testable p, Show a) =>+ Gen a ->+ (Text -> a -> b) ->+ [Text] ->+ ([b] -> p) ->+ Property+forAllLabeled g mkRow (l : ls) mkTest = forAll g $ \z -> forAllLabeled g mkRow ls $ mkTest . (mkRow l z :)+forAllLabeled _ _ _ mkTest = property $ mkTest []