{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-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 ]